Rakka/Resource/TrackBack.hs

   1 module Rakka.Resource.TrackBack
   2     ( resTrackBack
   3     )
   4     where
   5
   6 import qualified Codec.Binary.UTF8.String as UTF8
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import           Control.Monad.Trans
  10 import           Data.List
  11 import           Data.Maybe
  12 import           Data.Time
  13 import           Network.Browser
  14 import           Network.HTTP
  15 import           Network.HTTP.Lucu
  16 import           Network.HTTP.Lucu.Utils
  17 import           Network.URI
  18 import           Rakka.Environment
  19 import           Rakka.Page
  20 import           Rakka.Storage
  21 import           Rakka.SystemConfig
  22 import           Rakka.TrackBack
  23 import           Text.XML.HXT.Arrow.WriteDocument
  24 import           Text.XML.HXT.Arrow.XmlArrow
  25 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  26 import           Text.XML.HXT.DOM.TypeDefs
  27 import           Text.XML.HXT.DOM.XmlKeywords
  28
  29
  30 data TBResponse
  31     = NoError
  32     | Error !Int !String
  33     deriving (Show, Eq)
  34
  35
  36 resTrackBack :: Environment -> ResourceDef
  37 resTrackBack env
  38     = ResourceDef {
  39         resUsesNativeThread = False
  40       , resIsGreedy         = True
  41       , resGet              = Nothing
  42       , resHead             = Nothing
  43       , resPost             = Just $ getPathInfo >>= handlePost env . toPageName
  44       , resPut              = Nothing
  45       , resDelete           = Nothing
  46       }
  47     where
  48       toPageName :: [String] -> PageName
  49       toPageName = decodePageName . joinWith "/"
  50
  51
  52 handlePost :: Environment -> PageName -> Resource ()
  53 handlePost env name
  54     = do form     <- inputForm defaultLimit
  55          tbParamM <- validateTrackBack form
  56          case tbParamM of
  57            Nothing
  58                -> return ()
  59            Just tbParam
  60                -> do cited <- liftIO $ checkCitation tbParam name
  61                      if cited then
  62                          do pageM <- getPage (envStorage env) name Nothing
  63                             case pageM of
  64                               Nothing   -> setStatus NotFound
  65                               Just page -> addTB tbParam page
  66                        else
  67                          outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
  68     where
  69       addTB :: TrackBack -> Page -> Resource ()
  70       addTB tbParam page
  71           | isRedirect page
  72               = do BaseURI baseURI <- getSysConf (envSysConf env)
  73                    redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
  74           | otherwise
  75               = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
  76                    st      <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
  77                    setStatus st
  78
  79
  80 validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
  81 validateTrackBack form
  82     = do let title    = get' "title"
  83              excerpt  = get' "excerpt"
  84              blogName = get' "blogName"
  85          case get' "url" of
  86            Nothing
  87                -> do outputResponse (Error 1 "Parameter `url' is missing.")
  88                      return Nothing
  89            Just u
  90                -> case parseURI u of
  91                     Nothing
  92                         -> do outputResponse (Error 1 "Parameter `url' is malformed.")
  93                               return Nothing
  94                     Just url
  95                         -> do time <- liftIO getCurrentTime
  96                               return $ Just TrackBack {
  97                                            tbTitle    = title
  98                                          , tbExcerpt  = excerpt
  99                                          , tbURL      = url
 100                                          , tbBlogName = blogName
 101                                          , tbTime     = time
 102                                          }
 103     where
 104       get' :: String -> Maybe String
 105       get' = fmap UTF8.decodeString . flip lookup form
 106
 107
 108 outputResponse :: TBResponse -> Resource ()
 109 outputResponse res
 110     = do setContentType $ read "text/xml"
 111          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
 112                                      >>>
 113                                      mkResponseTree
 114                                      >>>
 115                                      writeDocumentToString [ (a_indent, v_1) ]
 116                                    )
 117          output xmlStr
 118     where
 119       mkResponseTree :: ArrowXml a => a b XmlTree
 120       mkResponseTree
 121           = proc _
 122           -> ( eelem "/"
 123                += ( eelem "response"
 124                     += ( eelem "error"
 125                          += txt (case res of
 126                                    NoError      -> "0"
 127                                    Error code _ -> show code)
 128                        )
 129                     += ( case res of
 130                            NoError     -> none
 131                            Error _ msg -> ( eelem "message"
 132                                             += txt msg
 133                                           )
 134                        )
 135                   )
 136              ) -< ()
 137
 138
 139 checkCitation :: TrackBack -> PageName -> IO Bool
 140 checkCitation param name
 141     = do (_, res) <- browse $
 142                      do setAllowRedirects True
 143                         setErrHandler (\ _ -> return ())
 144                         setOutHandler (\ _ -> return ())
 145                         request $ defaultGETRequest $ tbURL param
 146          case rspCode res of
 147            (2, 0, 0)
 148                -> return (encodePageName name `isInfixOf` rspBody res)
 149            _   -> return False