bugfix

[Rakka.git] / Rakka / Resource / TrackBack.hs

diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs
index ca2635738d6216b951aa932428591577bebd723e..145e307c555631af4da708504da1070285da14ea 100644 (file)
--- a/Rakka/Resource/TrackBack.hs
+++ b/Rakka/Resource/TrackBack.hs
@@ -9,13 +9,18 @@ import           Control.Arrow.ArrowList
 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
@@ -23,16 +28,6 @@ import           Text.XML.HXT.DOM.TypeDefs
 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
@@ -58,23 +53,39 @@ resTrackBack env
 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.")
@@ -85,12 +96,14 @@ validateTBParam form
                         -> 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
@@ -127,7 +140,7 @@ outputResponse res
              ) -< ()
 
 
-checkCitation :: TBParam -> PageName -> IO Bool
+checkCitation :: TrackBack -> PageName -> IO Bool
 checkCitation param name
     = do (_, res) <- browse $
                      do setAllowRedirects True