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.Response
  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 = UTF8.decodeString . joinPath
  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                    if isSuccessful st then
  78                        outputResponse NoError
  79                      else
  80                        setStatus st
  81
  82
  83 validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
  84 validateTrackBack form
  85     = do let title    = get' "title"
  86              excerpt  = get' "excerpt"
  87              blogName = get' "blog_name"
  88          case get' "url" of
  89            Nothing
  90                -> do outputResponse (Error 1 "Parameter `url' is missing.")
  91                      return Nothing
  92            Just u
  93                -> case parseURI u of
  94                     Nothing
  95                         -> do outputResponse (Error 1 "Parameter `url' is malformed.")
  96                               return Nothing
  97                     Just url
  98                         -> do time <- liftIO getCurrentTime
  99                               return $ Just TrackBack {
 100                                            tbTitle    = title
 101                                          , tbExcerpt  = excerpt
 102                                          , tbURL      = url
 103                                          , tbBlogName = blogName
 104                                          , tbTime     = time
 105                                          }
 106     where
 107       get' :: String -> Maybe String
 108       get' = fmap UTF8.decodeString . flip lookup form
 109
 110
 111 outputResponse :: TBResponse -> Resource ()
 112 outputResponse res
 113     = do setContentType $ read "text/xml"
 114          [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
 115                                      >>>
 116                                      mkResponseTree
 117                                      >>>
 118                                      writeDocumentToString [ (a_indent         , v_1 )
 119                                                            , (a_output_encoding, utf8)
 120                                                            , (a_no_xml_pi      , v_0 ) ]
 121                                    )
 122          output $ UTF8.encodeString xmlStr
 123     where
 124       mkResponseTree :: ArrowXml a => a b XmlTree
 125       mkResponseTree
 126           = proc _
 127           -> ( eelem "/"
 128                += ( eelem "response"
 129                     += ( eelem "error"
 130                          += txt (case res of
 131                                    NoError      -> "0"
 132                                    Error code _ -> show code)
 133                        )
 134                     += ( case res of
 135                            NoError     -> none
 136                            Error _ msg -> ( eelem "message"
 137                                             += txt msg
 138                                           )
 139                        )
 140                   )
 141              ) -< ()
 142
 143
 144 checkCitation :: TrackBack -> PageName -> IO Bool
 145 checkCitation param name
 146     = do (_, res) <- browse $
 147                      do setAllowRedirects True
 148                         setErrHandler (\ _ -> return ())
 149                         setOutHandler (\ _ -> return ())
 150                         request $ defaultGETRequest $ tbURL param
 151          case rspCode res of
 152            (2, 0, 0)
 153                -> return (encodePageName name `isInfixOf` rspBody res)
 154            _   -> return False