Rakka/Resource.hs

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