Resurrection from bitrot

[Rakka.git] / Rakka / Resource / Users.hs

diff --git a/Rakka/Resource/Users.hs b/Rakka/Resource/Users.hs
index fa61ad86fbe373bf38133dd365a004d6cf4f2f2d..a892c9f914d1811f531dca0dafb3d7151cfad987 100644 (file)
--- a/Rakka/Resource/Users.hs
+++ b/Rakka/Resource/Users.hs
@@ -1,17 +1,28 @@
+{-# LANGUAGE
+    Arrows
+  , DoAndIfThenElse
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Rakka.Resource.Users
     ( resUsers
     )
     where
-
-import           Control.Monad
-import           Control.Monad.Trans
-import           Data.Maybe
-import           Network.HTTP.Lucu
-import           Rakka.Authorization
-import           Rakka.Environment
-import           Rakka.Resource
-import           Text.XML.HXT.Arrow hiding (when)
-
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode
+import Control.Monad
+import Control.Monad.Trans
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.HTTP.Lucu
+import Prelude.Unicode
+import Rakka.Authorization
+import Rakka.Environment
+import Rakka.Resource
+import Text.XML.HXT.Arrow.XmlArrow
 
 resUsers :: Environment -> ResourceDef
 resUsers env
@@ -40,41 +51,37 @@ resUsers env
   [GET /users/nonexistent]
   404 Not Found
 -}
-handleGet :: Environment -> Resource ()
-handleGet env
-    = do userID <- getUserID env
-        when (isNothing userID)
+handleGet ∷ Environment → Resource ()
+handleGet env@(Environment {..})
+    = do userID ← getUserID env
+         when (isNothing userID)
                   $ abort Forbidden [] Nothing
 
-        path <- getPathInfo
-        case path of
-          []     -> returnUserList
-          [name] -> returnUser name
-          _      -> foundNoEntity Nothing
+         path ← getPathInfo
+         case path of
+           []     → returnUserList
+           [name] → returnUser (T.pack name)
+           _      → foundNoEntity Nothing
     where
-    returnUserList :: Resource ()
-    returnUserList
-       = do users <- liftIO $ getUserList $ envAuthDB env
-            runIdempotentA' $ proc ()
-                -> do tree <- ( eelem "/"
-                                += ( eelem "users"
-                                     += ( constL users
-                                          >>>
-                                          ( eelem "user"
-                                            += attr "id" mkText
-                                          )
-                                        )
-                                   )
-                              ) -< ()
-                      returnA -< outputXml tree
-
-    returnUser :: String -> Resource ()
-    returnUser name
-       = do users <- liftIO $ getUserList $ envAuthDB env
-            if any (== name) users
-               then setStatus NoContent
-               else foundNoEntity Nothing
-
+      returnUserList ∷ Resource ()
+      returnUserList
+          = do users ← liftIO $ getUserList envAuthDB
+               runIdempotentA' $ proc ()
+                 → do tree ← ( eelem "/"
+                               += ( eelem "users"
+                                    += ( constL users
+                                         ⋙
+                                         ( eelem "user"
+                                           += attr "id" (arr T.unpack ⋙ mkText)
+                                         ) ) ) ) ⤙ ()
+                      returnA ⤙ outputXml tree
+
+      returnUser ∷ Text → Resource ()
+      returnUser name
+          = do users ← liftIO $ getUserList envAuthDB
+               if any (≡ name) users
+               then setStatus NoContent
+               else foundNoEntity Nothing
 
 {-
   > PUT /users/foo HTTP/1.1
@@ -84,35 +91,34 @@ handleGet env
 
   < HTTP/1.1 201 Created
 -}
-handlePut :: Environment -> Resource ()
+handlePut ∷ Environment → Resource ()
 handlePut env
-    = do userID <- getUserID env
-        when (isNothing userID)
-                 $ abort Forbidden [] Nothing
-
-        path <- getPathInfo
-        case path of
-          [name] -> do mimeType <- getContentType
-                       case mimeType of
-                         Nothing
-                             -> abort BadRequest [] (Just "Missing Content-Type")
-                         Just (MIMEType "text" "plain" _)
-                             -> do pass <- input defaultLimit
-                                   addUser (envAuthDB env) name pass
-                         Just t
-                             -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
-                        setStatus Created
-          _      -> abort BadRequest [] (Just "Invalid URI")
-
+    = do userID ← getUserID env
+         when (isNothing userID)
+                  $ abort Forbidden [] Nothing
 
-handleDelete :: Environment -> Resource ()
+         path ← getPathInfo
+         case path of
+           [name] → do mimeType ← getContentType
+                       case mimeType of
+                         Nothing
+                             → abort BadRequest [] (Just "Missing Content-Type")
+                         Just (MIMEType "text" "plain" _)
+                             → do pass ← input defaultLimit
+                                  addUser (envAuthDB env) (T.pack name) (T.pack pass)
+                         Just t
+                             → abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ⊕ show t)
+                       setStatus Created
+           _      → abort BadRequest [] (Just "Invalid URI")
+
+handleDelete ∷ Environment → Resource ()
 handleDelete env
-    = do userID <- getUserID env
+    = do userID ← getUserID env
         when (isNothing userID)
-                 $ abort Forbidden [] Nothing
+             $ abort Forbidden [] Nothing
 
-        path <- getPathInfo
+        path ← getPathInfo
         case path of
-          [name] -> delUser (envAuthDB env) name
-          _      -> abort BadRequest [] (Just "Invalid URI")
+          [name] → delUser (envAuthDB env) (T.pack name)
+          _      → abort BadRequest [] (Just "Invalid URI")
         setStatus NoContent