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