( 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)
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
handleGet env
= do userID <- getUserID env
when (isNothing userID)
- $ abort Forbidden [] Nothing
+ $ abort Forbidden [] Nothing
path <- getPathInfo
case path of
- [] -> returnUserList
- [name] -> returnUser name
- _ -> foundNoEntity Nothing
+ [] -> returnUserList
+ [name] -> returnUser name
+ _ -> foundNoEntity Nothing
where
returnUserList :: Resource ()
returnUserList
- = do BaseURI baseURI <- getSysConf (envSysConf env)
- users <- liftIO $ getUserList $ envAuthDB env
+ = do 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
- )
- )
- )
- )
- )
+ += ( eelem "users"
+ += ( constL users
+ >>>
+ ( eelem "user"
+ += attr "id" 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
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")
+ [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 ()
path <- getPathInfo
case path of
- [name] -> delUser (envAuthDB env) name
- _ -> abort BadRequest [] (Just "Invalid URI")
+ [name] -> delUser (envAuthDB env) name
+ _ -> abort BadRequest [] (Just "Invalid URI")
setStatus NoContent