Rakka/Resource/Users.hs

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