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