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