X-Git-Url: https://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FResource%2FTrackBack.hs;h=ad367cd0f287fbb783d30356c153cf410d2665df;hp=ca2635738d6216b951aa932428591577bebd723e;hb=e85b652169f502cffe1f6f7f927d8990e9c11499;hpb=d843e97aa04278677eaede4e50ef680af32867e7

diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs
index ca26357..ad367cd 100644
--- a/Rakka/Resource/TrackBack.hs
+++ b/Rakka/Resource/TrackBack.hs
@@ -9,6 +9,7 @@ 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
@@ -16,6 +17,9 @@ 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 +27,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,20 +52,33 @@ 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)
+                   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"
@@ -85,12 +92,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 +136,7 @@ outputResponse res
              ) -< ()
 
 
-checkCitation :: TBParam -> PageName -> IO Bool
+checkCitation :: TrackBack -> PageName -> IO Bool
 checkCitation param name
     = do (_, res) <- browse $
                      do setAllowRedirects True