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