Rakka/Resource.hs

   1 module Rakka.Resource
   2     ( runIdempotentA
   3     , runXmlA
   4     , outputXmlPage
   5     )
   6     where
   7
   8 import           Control.Arrow
   9 import           Control.Arrow.ArrowList
  10 import           Control.Monad
  11 import           Control.Monad.Trans
  12 import           Network.HTTP.Lucu
  13 import           Network.HTTP.Lucu.Utils
  14 import           Network.URI hiding (path)
  15 import           Rakka.Environment
  16 import           Rakka.Validation
  17 import           Text.XML.HXT.Arrow.ReadDocument
  18 import           Text.XML.HXT.Arrow.WriteDocument
  19 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  20 import           Text.XML.HXT.DOM.TypeDefs
  21 import           Text.XML.HXT.DOM.XmlKeywords
  22
  23
  24 -- "/"         ==> "/"
  25 -- "/foo"      ==> "/foo.html"
  26 -- "/foo/"     ==> "/foo.html"
  27 -- "/foo.bar/" ==> "/foo.bar"
  28 -- "/foo.bar"  ==> "/foo.bar"
  29 canonicalizeURI :: Resource ()
  30 canonicalizeURI
  31     = do uri <- getRequestURI
  32          let newURI  = uri { uriPath = "/" ++ joinWith "/" newPath }
  33              newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
  34                          []   -> []
  35                          path -> case break (== '.') $ last path of
  36                                    (_, "") -> let basePieces = reverse $ tail $ reverse path
  37                                                   lastPiece  = last path
  38                                               in
  39                                                 basePieces ++ [lastPiece ++ ".html"]
  40                                    (_, _)  -> path
  41          when (uri /= newURI)
  42               $ abort MovedPermanently
  43                 [("Location", uriToString id newURI $ "")]
  44                 Nothing
  45
  46
  47 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
  48 runIdempotentA a
  49     = do canonicalizeURI
  50          [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
  51                                    >>>
  52                                    constA ()
  53                                    >>>
  54                                    a
  55                                  )
  56          rsrc
  57
  58
  59 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
  60 runXmlA env schemaPath a
  61     = do inputA <- getInputXmlA env schemaPath
  62          [rsrc] <- liftIO $ runX ( inputA
  63                                    >>>
  64                                    setErrorMsgHandler False fail
  65                                    >>>
  66                                    a
  67                                  )
  68          rsrc
  69
  70
  71 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
  72 -- Unprocessable Entity になる。入力の型が XML でない時は 415
  73 -- Unsupported Media Type を返す。
  74 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
  75 getInputXmlA env schemaPath
  76     = do reader    <- getInputReader
  77          validator <- getValidator env schemaPath
  78          return ( setErrorMsgHandler False (abort BadRequest [] . Just)
  79                   >>>
  80                   reader
  81                   >>>
  82                   setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
  83                   >>>
  84                   validator
  85                 )
  86
  87
  88 getInputReader :: Resource (IOSArrow b XmlTree)
  89 getInputReader
  90     = do mimeType <- getContentType
  91          case mimeType of
  92            Nothing
  93                -> getFailingReader BadRequest [] (Just "Missing Content-Type")
  94            Just (MIMEType "text" "xml" _)
  95                -> getXmlReader
  96            Just (MIMEType "application" "xml" _)
  97                -> getXmlReader
  98            Just t
  99                -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
 100     where
 101       getXmlReader
 102           = do req <- input defaultLimit
 103                return $ readString [ (a_validate         , v_0)
 104                                    , (a_check_namespaces , v_1)
 105                                    , (a_remove_whitespace, v_0)
 106                                    ] req
 107       getFailingReader code headers msg
 108           = return $ proc _ -> abortA -< (code, (headers, msg))
 109
 110
 111 getEntityType :: Resource MIMEType
 112 getEntityType
 113     = do uri <- getRequestURI
 114          let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
 115          case lookup ext extMap of
 116            Just mType -> return mType
 117            Nothing    -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
 118     where
 119       extMap :: [(String, MIMEType)]
 120       extMap = [ ("html", read "application/xhtml+xml")
 121                , ( "xml", read "text/xml"             )
 122                ]
 123
 124
 125 outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
 126 outputXmlPage tree toXHTML
 127     = do mType <- getEntityType
 128          setContentType mType
 129          let formatter = case mType of
 130                            MIMEType "application" "xhtml+xml" _ -> toXHTML
 131                            MIMEType "text"        "xml"       _ -> this
 132                            _                                    -> undefined
 133          [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
 134                                         >>>
 135                                         constA tree
 136                                         >>>
 137                                         formatter
 138                                         >>>
 139                                         writeDocumentToString [ (a_indent, v_1) ]
 140                                       )
 141          output resultStr