Rakka/Resource.hs

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