1 module Rakka.Resource.Users
7 import Control.Monad.Trans
9 import Network.HTTP.Lucu
10 import Network.URI hiding (path)
11 import Rakka.Authorization
12 import Rakka.Environment
14 import Rakka.SystemConfig
15 import System.FilePath
16 import Text.XML.HXT.Arrow hiding (when)
19 resUsers :: Environment -> ResourceDef
22 resUsesNativeThread = False
24 , resGet = Just $ handleGet env
27 , resPut = Just $ handlePut env
28 , resDelete = Just $ handleDelete env
35 <rdf:Description rdf:about="http://.../users">
38 <rdf:li rdf:resource="http://.../users/foo" />
39 <rdf:li rdf:resource="http://.../users/bar" />
49 [GET /users/nonexistent]
52 handleGet :: Environment -> Resource ()
54 = do userID <- getUserID env
55 when (isNothing userID)
56 $ abort Forbidden [] Nothing
61 [name] -> returnUser name
62 _ -> foundNoEntity Nothing
64 returnUserList :: Resource ()
66 = do BaseURI baseURI <- getSysConf (envSysConf env)
67 users <- liftIO $ getUserList $ envAuthDB env
68 runIdempotentA' $ proc ()
69 -> do tree <- ( eelem "/"
71 += sattr "xmlns" "http://cielonegro.org/terms/"
72 += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
73 += ( eelem "rdf:Description"
74 += sattr "rdf:about" (uriToString id (mkUserURI baseURI Nothing) "")
80 += attr "rdf:resource" ( arr ( \ name ->
83 (mkUserURI baseURI $ Just name)
96 returnA -< outputXml tree
98 mkUserURI :: URI -> Maybe String -> URI
99 mkUserURI baseURI Nothing = baseURI { uriPath = uriPath baseURI </> "users" }
100 mkUserURI baseURI (Just x) = baseURI { uriPath = uriPath baseURI </> "users" </> x }
102 returnUser :: String -> Resource ()
104 = do users <- liftIO $ getUserList $ envAuthDB env
105 if any (== name) users
106 then setStatus NoContent
107 else foundNoEntity Nothing
111 > PUT /users/foo HTTP/1.1
112 > Content-Type: text/plain
116 < HTTP/1.1 201 Created
118 handlePut :: Environment -> Resource ()
120 = do userID <- getUserID env
121 when (isNothing userID)
122 $ abort Forbidden [] Nothing
126 [name] -> do mimeType <- getContentType
129 -> abort BadRequest [] (Just "Missing Content-Type")
130 Just (MIMEType "text" "plain" _)
131 -> do pass <- input defaultLimit
132 addUser (envAuthDB env) name pass
134 -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
136 _ -> abort BadRequest [] (Just "Invalid URI")
139 handleDelete :: Environment -> Resource ()
141 = do userID <- getUserID env
142 when (isNothing userID)
143 $ abort Forbidden [] Nothing
147 [name] -> delUser (envAuthDB env) name
148 _ -> abort BadRequest [] (Just "Invalid URI")