X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FUsers.hs;fp=Rakka%2FResource%2FUsers.hs;h=a892c9f914d1811f531dca0dafb3d7151cfad987;hb=42f51754dea02201aececaacbf194d714cd58aaf;hp=fa61ad86fbe373bf38133dd365a004d6cf4f2f2d;hpb=98fd1cb53a837a9bda7145544c34872acb13a634;p=Rakka.git

diff --git a/Rakka/Resource/Users.hs b/Rakka/Resource/Users.hs
index fa61ad8..a892c9f 100644
--- 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