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