+{-# LANGUAGE
+ Arrows
+ , DoAndIfThenElse
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Rakka.Resource.Users
( resUsers
)
where
-
-import Control.Monad
-import Control.Monad.Trans
-import Data.Maybe
-import Network.HTTP.Lucu
-import Network.URI hiding (path)
-import Rakka.Authorization
-import Rakka.Environment
-import Rakka.Resource
-import Rakka.SystemConfig
-import System.FilePath
-import Text.XML.HXT.Arrow hiding (when)
-
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode
+import Control.Monad
+import Control.Monad.Trans
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.HTTP.Lucu
+import Prelude.Unicode
+import Rakka.Authorization
+import Rakka.Environment
+import Rakka.Resource
+import Text.XML.HXT.Arrow.XmlArrow
resUsers :: Environment -> ResourceDef
resUsers env
= ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = True
- , resGet = Just $ handleGet env
- , resHead = Nothing
- , resPost = Nothing
- , resPut = Just $ handlePut env
- , resDelete = Just $ handleDelete env
- }
+ resUsesNativeThread = False
+ , resIsGreedy = True
+ , resGet = Just $ handleGet env
+ , resHead = Nothing
+ , resPost = Nothing
+ , resPut = Just $ handlePut env
+ , resDelete = Just $ handleDelete env
+ }
{-
[GET /users]
- <rdf:RDF>
- <rdf:Description rdf:about="http://.../users">
- <users>
- <rdf:Bag>
- <rdf:li rdf:resource="http://.../users/foo" />
- <rdf:li rdf:resource="http://.../users/bar" />
- ...
- </rdf:Bag>
- </users>
- </rdf:Description>
- </rdf:RDF>
+ <users>
+ <user id="foo" />
+ <user id="bar" />
+ ...
+ </users>
[GET /users/foo]
204 No Content
[GET /users/nonexistent]
404 Not Found
-}
-handleGet :: Environment -> Resource ()
-handleGet env
- = do userID <- getUserID env
- when (isNothing userID)
- $ abort Forbidden [] Nothing
-
- path <- getPathInfo
- case path of
- [] -> returnUserList
- [name] -> returnUser name
- _ -> foundNoEntity Nothing
+handleGet ∷ Environment → Resource ()
+handleGet env@(Environment {..})
+ = do userID ← getUserID env
+ when (isNothing userID)
+ $ abort Forbidden [] Nothing
+
+ path ← getPathInfo
+ case path of
+ [] → returnUserList
+ [name] → returnUser (T.pack name)
+ _ → foundNoEntity Nothing
where
- returnUserList :: Resource ()
- returnUserList
- = do BaseURI baseURI <- getSysConf (envSysConf env)
- users <- liftIO $ getUserList $ envAuthDB env
- runIdempotentA' $ proc ()
- -> do tree <- ( eelem "/"
- += ( eelem "rdf:RDF"
- += sattr "xmlns" "http://cielonegro.org/terms/"
- += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
- += ( eelem "rdf:Description"
- += sattr "rdf:about" (uriToString id (mkUserURI baseURI Nothing) "")
- += ( eelem "users"
- += ( eelem "rdf:Bag"
- += ( constL users
- >>>
- ( eelem "rdf:li"
- += attr "rdf:resource" ( arr ( \ name ->
- uriToString
- id
- (mkUserURI baseURI $ Just name)
- ""
- )
- >>>
- mkText
- )
- )
- )
- )
- )
- )
- )
- ) -< ()
- returnA -< outputXml tree
-
- mkUserURI :: URI -> Maybe String -> URI
- mkUserURI baseURI Nothing = baseURI { uriPath = uriPath baseURI </> "users" }
- mkUserURI baseURI (Just x) = baseURI { uriPath = uriPath baseURI </> "users" </> x }
-
- returnUser :: String -> Resource ()
- returnUser name
- = do users <- liftIO $ getUserList $ envAuthDB env
- if any (== name) users
- then setStatus NoContent
- else foundNoEntity Nothing
-
+ returnUserList ∷ Resource ()
+ returnUserList
+ = do users ← liftIO $ getUserList envAuthDB
+ runIdempotentA' $ proc ()
+ → do tree ← ( eelem "/"
+ += ( eelem "users"
+ += ( constL users
+ ⋙
+ ( eelem "user"
+ += attr "id" (arr T.unpack ⋙ mkText)
+ ) ) ) ) ⤙ ()
+ returnA ⤙ outputXml tree
+
+ returnUser ∷ Text → Resource ()
+ returnUser name
+ = do users ← liftIO $ getUserList envAuthDB
+ if any (≡ name) users
+ then setStatus NoContent
+ else foundNoEntity Nothing
{-
> PUT /users/foo HTTP/1.1
< HTTP/1.1 201 Created
-}
-handlePut :: Environment -> Resource ()
+handlePut ∷ Environment → Resource ()
handlePut env
- = do userID <- getUserID env
- when (isNothing userID)
- $ abort Forbidden [] Nothing
-
- path <- getPathInfo
- case path of
- [name] -> do mimeType <- getContentType
- case mimeType of
- Nothing
- -> abort BadRequest [] (Just "Missing Content-Type")
- Just (MIMEType "text" "plain" _)
- -> do pass <- input defaultLimit
- addUser (envAuthDB env) name pass
- Just t
- -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
- setStatus Created
- _ -> abort BadRequest [] (Just "Invalid URI")
-
-
-handleDelete :: Environment -> Resource ()
+ = do userID ← getUserID env
+ when (isNothing userID)
+ $ abort Forbidden [] Nothing
+
+ path ← getPathInfo
+ case path of
+ [name] → do mimeType ← getContentType
+ case mimeType of
+ Nothing
+ → abort BadRequest [] (Just "Missing Content-Type")
+ Just (MIMEType "text" "plain" _)
+ → do pass ← input defaultLimit
+ addUser (envAuthDB env) (T.pack name) (T.pack pass)
+ Just t
+ → abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ⊕ show t)
+ setStatus Created
+ _ → abort BadRequest [] (Just "Invalid URI")
+
+handleDelete ∷ Environment → Resource ()
handleDelete env
- = do userID <- getUserID env
+ = do userID ← getUserID env
when (isNothing userID)
- $ abort Forbidden [] Nothing
+ $ abort Forbidden [] Nothing
- path <- getPathInfo
+ path ← getPathInfo
case path of
- [name] -> delUser (envAuthDB env) name
- _ -> abort BadRequest [] (Just "Invalid URI")
+ [name] → delUser (envAuthDB env) (T.pack name)
+ _ → abort BadRequest [] (Just "Invalid URI")
setStatus NoContent
projects / Rakka.git / blobdiff