Rakka/Resource/Users.hs

   1 {-# LANGUAGE
   2     Arrows
   3   , DoAndIfThenElse
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   #-}
   7 module Rakka.Resource.Users
   8     ( resUsers
   9     )
  10     where
  11 import Control.Arrow
  12 import Control.Arrow.ArrowList
  13 import Control.Arrow.Unicode
  14 import Control.Monad
  15 import Control.Monad.Trans
  16 import Data.Maybe
  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
  24 import Rakka.Resource
  25 import Text.XML.HXT.Arrow.XmlArrow
  26
  27 resUsers :: Environment -> ResourceDef
  28 resUsers env
  29     = ResourceDef {
  30         resUsesNativeThread = False
  31       , resIsGreedy        = True
  32       , resGet             = Just $ handleGet env
  33       , resHead            = Nothing
  34       , resPost            = Nothing
  35       , resPut             = Just $ handlePut env
  36       , resDelete          = Just $ handleDelete env
  37       }
  38
  39
  40 {-
  41   [GET /users]
  42   <users>
  43     <user id="foo" />
  44     <user id="bar" />
  45     ...
  46   </users>
  47
  48   [GET /users/foo]
  49   204 No Content
  50
  51   [GET /users/nonexistent]
  52   404 Not Found
  53 -}
  54 handleGet ∷ Environment → Resource ()
  55 handleGet env@(Environment {..})
  56     = do userID ← getUserID env
  57          when (isNothing userID)
  58                   $ abort Forbidden [] Nothing
  59
  60          path ← getPathInfo
  61          case path of
  62            []     → returnUserList
  63            [name] → returnUser (T.pack name)
  64            _      → foundNoEntity Nothing
  65     where
  66       returnUserList ∷ Resource ()
  67       returnUserList
  68           = do users ← liftIO $ getUserList envAuthDB
  69                runIdempotentA' $ proc ()
  70                  → do tree ← ( eelem "/"
  71                                += ( eelem "users"
  72                                     += ( constL users
  73                                          ⋙
  74                                          ( eelem "user"
  75                                            += attr "id" (arr T.unpack ⋙ mkText)
  76                                          ) ) ) ) ⤙ ()
  77                       returnA ⤙ outputXml tree
  78
  79       returnUser ∷ Text → Resource ()
  80       returnUser name
  81           = do users ← liftIO $ getUserList envAuthDB
  82                if any (≡ name) users
  83                then setStatus NoContent
  84                else foundNoEntity Nothing
  85
  86 {-
  87   > PUT /users/foo HTTP/1.1
  88   > Content-Type: text/plain
  89   >
  90   > password
  91
  92   < HTTP/1.1 201 Created
  93 -}
  94 handlePut ∷ Environment → Resource ()
  95 handlePut env
  96     = do userID ← getUserID env
  97          when (isNothing userID)
  98                   $ abort Forbidden [] Nothing
  99
 100          path ← getPathInfo
 101          case path of
 102            [name] → do mimeType ← getContentType
 103                        case mimeType of
 104                          Nothing
 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)
 109                          Just t
 110                              → abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ⊕ show t)
 111                        setStatus Created
 112            _      → abort BadRequest [] (Just "Invalid URI")
 113
 114 handleDelete ∷ Environment → Resource ()
 115 handleDelete env
 116     = do userID ← getUserID env
 117          when (isNothing userID)
 118              $ abort Forbidden [] Nothing
 119
 120          path ← getPathInfo
 121          case path of
 122            [name] → delUser (envAuthDB env) (T.pack name)
 123            _      → abort BadRequest [] (Just "Invalid URI")
 124          setStatus NoContent