+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)
+
+
+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
+ }
+
+
+{-
+ [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>
+
+ [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
+ 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
+
+
+{-
+ > PUT /users/foo HTTP/1.1
+ > Content-Type: text/plain
+ >
+ > password
+
+ < HTTP/1.1 201 Created
+-}
+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 ()
+handleDelete env
+ = do userID <- getUserID env
+ when (isNothing userID)
+ $ abort Forbidden [] Nothing
+
+ path <- getPathInfo
+ case path of
+ [name] -> delUser (envAuthDB env) name
+ _ -> abort BadRequest [] (Just "Invalid URI")
+ setStatus NoContent