I'm getting tired so I must have a rest.

[Rakka.git] / Rakka / Resource.hs

diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs
new file mode 100644 (file)
index 0000000..c79b215
--- /dev/null
+++ b/Rakka/Resource.hs
@@ -0,0 +1,85 @@
+module Rakka.Resource
+    ( runIdempotentA
+    , outputXmlPage
+    )
+    where
+
+import           Control.Arrow
+import           Control.Arrow.ArrowList
+import           Control.Monad
+import           Control.Monad.Trans
+import           Network.HTTP.Lucu
+import           Network.HTTP.Lucu.Utils
+import           Network.URI
+import           Text.XML.HXT.Arrow.WriteDocument
+import           Text.XML.HXT.Arrow.XmlIOStateArrow
+import           Text.XML.HXT.DOM.TypeDefs
+import           Text.XML.HXT.DOM.XmlKeywords
+
+
+-- /         ==> /
+-- /foo      ==> /foo.html
+-- /foo/     ==> /foo.html
+-- /foo.bar/ ==> /foo.bar
+-- /foo.bar  ==> /foo.bar
+canonicalizeURI :: Resource ()
+canonicalizeURI 
+    = do uri <- getRequestURI
+         let newURI  = uri { uriPath = "/" ++ joinWith "/" newPath }
+             newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
+                         []   -> []
+                         path -> case break (== '.') $ last path of
+                                   (_, "") -> let basePieces = reverse $ tail $ reverse path
+                                                  lastPiece  = last path
+                                              in
+                                                basePieces ++ [lastPiece ++ ".html"]
+                                   (_, _)  -> path
+         when (uri /= newURI)
+              $ abort MovedPermanently
+                [("Location", uriToString id newURI $ "")]
+                Nothing
+
+
+runIdempotentA :: IOSArrow () (Resource c) -> Resource c
+runIdempotentA a
+    = do canonicalizeURI
+         [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
+                                   >>>
+                                   constA ()
+                                   >>>
+                                   a
+                                 )
+         rsrc
+
+
+getEntityType :: Resource MIMEType
+getEntityType
+    = do uri <- getRequestURI
+         let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
+         case lookup ext extMap of
+           Just mType -> return mType
+           Nothing    -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
+    where
+      extMap :: [(String, MIMEType)]
+      extMap = [ ("html", read "application/xhtml+xml")
+               , ( "xml", read "text/xml"             )
+               ]
+
+
+outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
+outputXmlPage tree toXHTML
+    = do mType <- getEntityType
+         setContentType mType
+         let formatter = if mType == read "text/xml" then
+                             this
+                         else
+                             toXHTML
+         [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+                                        >>>
+                                        constA tree
+                                        >>>
+                                        formatter
+                                        >>>
+                                        writeDocumentToString [ (a_indent, v_1) ]
+                                      )
+         output resultStr
\ No newline at end of file