Rakka/Resource.hs

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