import Control.Monad.Trans
import Data.List
import Data.Maybe
+import Data.Time
import Network.Browser
import Network.HTTP
import Network.HTTP.Lucu
+import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
import Network.URI
import Rakka.Environment
import Rakka.Page
+import Rakka.Storage
+import Rakka.SystemConfig
+import Rakka.TrackBack
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.DOM.XmlKeywords
-data TBParam
- = TBParam {
- tbTitle :: !(Maybe String)
- , tbExcerpt :: !(Maybe String)
- , tbURL :: !URI
- , tbBlogName :: !(Maybe String)
- }
- deriving (Show, Eq)
-
-
data TBResponse
= NoError
| Error !Int !String
handlePost :: Environment -> PageName -> Resource ()
handlePost env name
= do form <- inputForm defaultLimit
- tbParamM <- validateTBParam form
+ tbParamM <- validateTrackBack form
case tbParamM of
Nothing
-> return ()
Just tbParam
-> do cited <- liftIO $ checkCitation tbParam name
if cited then
- fail "not impl"
+ do pageM <- getPage (envStorage env) name Nothing
+ case pageM of
+ Nothing -> setStatus NotFound
+ Just page -> addTB tbParam page
else
outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
+ where
+ addTB :: TrackBack -> Page -> Resource ()
+ addTB tbParam page
+ | isRedirect page
+ = do BaseURI baseURI <- getSysConf (envSysConf env)
+ redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
+ | otherwise
+ = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
+ st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
+ if isSuccessful st then
+ outputResponse NoError
+ else
+ setStatus st
-validateTBParam :: [(String, String)] -> Resource (Maybe TBParam)
-validateTBParam form
+validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
+validateTrackBack form
= do let title = get' "title"
excerpt = get' "excerpt"
- blogName = get' "blogName"
+ blogName = get' "blog_name"
case get' "url" of
Nothing
-> do outputResponse (Error 1 "Parameter `url' is missing.")
-> do outputResponse (Error 1 "Parameter `url' is malformed.")
return Nothing
Just url
- -> return $ Just TBParam {
- tbTitle = title
- , tbExcerpt = excerpt
- , tbURL = url
- , tbBlogName = blogName
- }
+ -> do time <- liftIO getCurrentTime
+ return $ Just TrackBack {
+ tbTitle = title
+ , tbExcerpt = excerpt
+ , tbURL = url
+ , tbBlogName = blogName
+ , tbTime = time
+ }
where
get' :: String -> Maybe String
get' = fmap UTF8.decodeString . flip lookup form
) -< ()
-checkCitation :: TBParam -> PageName -> IO Bool
+checkCitation :: TrackBack -> PageName -> IO Bool
checkCitation param name
= do (_, res) <- browse $
do setAllowRedirects True