]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Resource/TrackBack.hs
new task to ditz
[Rakka.git] / 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 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