Rakka/Resource/Users.hs

   1 module Rakka.Resource.Users
   2     ( resUsers
   3     )
   4     where
   5 import           Control.Monad
   6 import           Control.Monad.Trans
   7 import           Data.Maybe
   8 import           Network.HTTP.Lucu
   9 import           Rakka.Authorization
  10 import           Rakka.Environment
  11 import           Rakka.Resource
  12
  13
  14 resUsers :: Environment -> ResourceDef
  15 resUsers env
  16     = ResourceDef {
  17         resUsesNativeThread = False
  18       , resIsGreedy        = True
  19       , resGet             = Just $ handleGet env
  20       , resHead            = Nothing
  21       , resPost            = Nothing
  22       , resPut             = Just $ handlePut env
  23       , resDelete          = Just $ handleDelete env
  24       }
  25
  26
  27 {-
  28   [GET /users]
  29   <users>
  30     <user id="foo" />
  31     <user id="bar" />
  32     ...
  33   </users>
  34
  35   [GET /users/foo]
  36   204 No Content
  37
  38   [GET /users/nonexistent]
  39   404 Not Found
  40 -}
  41 handleGet :: Environment -> Resource ()
  42 handleGet env
  43     = do userID <- getUserID env
  44          when (isNothing userID)
  45                   $ abort Forbidden [] Nothing
  46
  47          path <- getPathInfo
  48          case path of
  49            []     -> returnUserList
  50            [name] -> returnUser name
  51            _      -> foundNoEntity Nothing
  52     where
  53     returnUserList :: Resource ()
  54     returnUserList
  55         = do users <- liftIO $ getUserList $ envAuthDB env
  56              runIdempotentA' $ proc ()
  57                  -> do tree <- ( eelem "/"
  58                                  += ( eelem "users"
  59                                       += ( constL users
  60                                            >>>
  61                                            ( eelem "user"
  62                                              += attr "id" mkText
  63                                            )
  64                                          )
  65                                     )
  66                                ) -< ()
  67                        returnA -< outputXml tree
  68
  69     returnUser :: String -> Resource ()
  70     returnUser name
  71         = do users <- liftIO $ getUserList $ envAuthDB env
  72              if any (== name) users
  73                 then setStatus NoContent
  74                 else foundNoEntity Nothing
  75
  76
  77 {-
  78   > PUT /users/foo HTTP/1.1
  79   > Content-Type: text/plain
  80   >
  81   > password
  82
  83   < HTTP/1.1 201 Created
  84 -}
  85 handlePut :: Environment -> Resource ()
  86 handlePut env
  87     = do userID <- getUserID env
  88          when (isNothing userID)
  89                   $ abort Forbidden [] Nothing
  90
  91          path <- getPathInfo
  92          case path of
  93            [name] -> do mimeType <- getContentType
  94                         case mimeType of
  95                           Nothing
  96                               -> abort BadRequest [] (Just "Missing Content-Type")
  97                           Just (MIMEType "text" "plain" _)
  98                               -> do pass <- input defaultLimit
  99                                     addUser (envAuthDB env) name pass
 100                           Just t
 101                               -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
 102                         setStatus Created
 103            _      -> abort BadRequest [] (Just "Invalid URI")
 104
 105
 106 handleDelete :: Environment -> Resource ()
 107 handleDelete env
 108     = do userID <- getUserID env
 109          when (isNothing userID)
 110                   $ abort Forbidden [] Nothing
 111
 112          path <- getPathInfo
 113          case path of
 114            [name] -> delUser (envAuthDB env) name
 115            _      -> abort BadRequest [] (Just "Invalid URI")
 116          setStatus NoContent