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           Network.URI hiding (path)
  11 import           Rakka.Authorization
  12 import           Rakka.Environment
  13 import           Rakka.Resource
  14 import           Rakka.SystemConfig
  15 import           System.FilePath
  16 import           Text.XML.HXT.Arrow hiding (when)
  17
  18
  19 resUsers :: Environment -> ResourceDef
  20 resUsers env
  21     = ResourceDef {
  22                    resUsesNativeThread = False
  23                   , resIsGreedy        = True
  24                   , resGet             = Just $ handleGet env
  25                   , resHead            = Nothing
  26                   , resPost            = Nothing
  27                   , resPut             = Just $ handlePut env
  28                   , resDelete          = Just $ handleDelete env
  29                   }
  30
  31
  32 {-
  33   [GET /users]
  34   <rdf:RDF>
  35     <rdf:Description rdf:about="http://.../users">
  36       <users>
  37         <rdf:Bag>
  38           <rdf:li rdf:resource="http://.../users/foo" />
  39           <rdf:li rdf:resource="http://.../users/bar" />
  40           ...
  41         </rdf:Bag>
  42       </users>
  43     </rdf:Description>
  44   </rdf:RDF>
  45
  46   [GET /users/foo]
  47   204 No Content
  48
  49   [GET /users/nonexistent]
  50   404 Not Found
  51 -}
  52 handleGet :: Environment -> Resource ()
  53 handleGet env
  54     = do userID <- getUserID env
  55          when (isNothing userID)
  56                   $ abort Forbidden [] Nothing
  57
  58          path <- getPathInfo
  59          case path of
  60                    []     -> returnUserList
  61                    [name] -> returnUser name
  62                    _      -> foundNoEntity Nothing
  63     where
  64     returnUserList :: Resource ()
  65     returnUserList
  66         = do BaseURI baseURI <- getSysConf (envSysConf env)
  67              users           <- liftIO $ getUserList $ envAuthDB env
  68              runIdempotentA' $ proc ()
  69                  -> do tree <- ( eelem "/"
  70                                  += ( eelem "rdf:RDF"
  71                                       += sattr "xmlns"     "http://cielonegro.org/terms/"
  72                                       += sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
  73                                       += ( eelem "rdf:Description"
  74                                            += sattr "rdf:about" (uriToString id (mkUserURI baseURI Nothing) "")
  75                                            += ( eelem "users"
  76                                                 += ( eelem "rdf:Bag"
  77                                                      += ( constL users
  78                                                           >>>
  79                                                           ( eelem "rdf:li"
  80                                                             += attr "rdf:resource" ( arr ( \ name ->
  81                                                                                            uriToString
  82                                                                                            id
  83                                                                                            (mkUserURI baseURI $ Just name)
  84                                                                                            ""
  85                                                                                          )
  86                                                                                      >>>
  87                                                                                      mkText
  88                                                                                    )
  89                                                           )
  90                                                         )
  91                                                    )
  92                                               )
  93                                          )
  94                                     )
  95                                ) -< ()
  96                        returnA -< outputXml tree
  97
  98     mkUserURI :: URI -> Maybe String -> URI
  99     mkUserURI baseURI Nothing  = baseURI { uriPath = uriPath baseURI </> "users" }
 100     mkUserURI baseURI (Just x) = baseURI { uriPath = uriPath baseURI </> "users" </> x }
 101
 102     returnUser :: String -> Resource ()
 103     returnUser name
 104         = do users <- liftIO $ getUserList $ envAuthDB env
 105              if any (== name) users
 106                 then setStatus NoContent
 107                 else foundNoEntity Nothing
 108
 109
 110 {-
 111   > PUT /users/foo HTTP/1.1
 112   > Content-Type: text/plain
 113   >
 114   > password
 115
 116   < HTTP/1.1 201 Created
 117 -}
 118 handlePut :: Environment -> Resource ()
 119 handlePut env
 120     = do userID <- getUserID env
 121          when (isNothing userID)
 122                   $ abort Forbidden [] Nothing
 123
 124          path <- getPathInfo
 125          case path of
 126                    [name] -> do mimeType <- getContentType
 127                                 case mimeType of
 128                                               Nothing
 129                                                   -> abort BadRequest [] (Just "Missing Content-Type")
 130                                               Just (MIMEType "text" "plain" _)
 131                                                   -> do pass <- input defaultLimit
 132                                                         addUser (envAuthDB env) name pass
 133                                               Just t
 134                                                   -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
 135                                 setStatus Created
 136                    _      -> abort BadRequest [] (Just "Invalid URI")
 137
 138
 139 handleDelete :: Environment -> Resource ()
 140 handleDelete env
 141     = do userID <- getUserID env
 142          when (isNothing userID)
 143                   $ abort Forbidden [] Nothing
 144
 145          path <- getPathInfo
 146          case path of
 147                    [name] -> delUser (envAuthDB env) name
 148                    _      -> abort BadRequest [] (Just "Invalid URI")
 149          setStatus NoContent