Rakka/Resource.hs

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