7 module Rakka.Resource.Users
12 import Control.Arrow.ArrowList
13 import Control.Arrow.Unicode
15 import Control.Monad.Trans
17 import Data.Monoid.Unicode
18 import Data.Text (Text)
19 import qualified Data.Text as T
20 import Network.HTTP.Lucu
21 import Prelude.Unicode
22 import Rakka.Authorization
23 import Rakka.Environment
25 import Text.XML.HXT.Arrow.XmlArrow
27 resUsers :: Environment -> ResourceDef
30 resUsesNativeThread = False
32 , resGet = Just $ handleGet env
35 , resPut = Just $ handlePut env
36 , resDelete = Just $ handleDelete env
51 [GET /users/nonexistent]
54 handleGet ∷ Environment → Resource ()
55 handleGet env@(Environment {..})
56 = do userID ← getUserID env
57 when (isNothing userID)
58 $ abort Forbidden [] Nothing
63 [name] → returnUser (T.pack name)
64 _ → foundNoEntity Nothing
66 returnUserList ∷ Resource ()
68 = do users ← liftIO $ getUserList envAuthDB
69 runIdempotentA' $ proc ()
70 → do tree ← ( eelem "/"
75 += attr "id" (arr T.unpack ⋙ mkText)
77 returnA ⤙ outputXml tree
79 returnUser ∷ Text → Resource ()
81 = do users ← liftIO $ getUserList envAuthDB
83 then setStatus NoContent
84 else foundNoEntity Nothing
87 > PUT /users/foo HTTP/1.1
88 > Content-Type: text/plain
92 < HTTP/1.1 201 Created
94 handlePut ∷ Environment → Resource ()
96 = do userID ← getUserID env
97 when (isNothing userID)
98 $ abort Forbidden [] Nothing
102 [name] → do mimeType ← getContentType
105 → abort BadRequest [] (Just "Missing Content-Type")
106 Just (MIMEType "text" "plain" _)
107 → do pass ← input defaultLimit
108 addUser (envAuthDB env) (T.pack name) (T.pack pass)
110 → abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ⊕ show t)
112 _ → abort BadRequest [] (Just "Invalid URI")
114 handleDelete ∷ Environment → Resource ()
116 = do userID ← getUserID env
117 when (isNothing userID)
118 $ abort Forbidden [] Nothing
122 [name] → delUser (envAuthDB env) (T.pack name)
123 _ → abort BadRequest [] (Just "Invalid URI")