Rakka/Resource.hs

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