{-# LANGUAGE
    Arrows
  , DoAndIfThenElse
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Rakka.Resource.Users
    ( resUsers
    )
    where
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
    = ResourceDef {
	resUsesNativeThread = False
      , resIsGreedy        = True
      , resGet             = Just $ handleGet env
      , resHead            = Nothing
      , resPost            = Nothing
      , resPut             = Just $ handlePut env
      , resDelete          = Just $ handleDelete env
      }


{-
  [GET /users]
  <users>
    <user id="foo" />
    <user id="bar" />
    ...
  </users>

  [GET /users/foo]
  204 No Content

  [GET /users/nonexistent]
  404 Not Found
-}
handleGet ∷ Environment → Resource ()
handleGet env@(Environment {..})
    = do userID ← getUserID env
         when (isNothing userID)
                  $ abort Forbidden [] Nothing

         path ← getPathInfo
         case path of
           []     → returnUserList
           [name] → returnUser (T.pack name)
           _      → foundNoEntity Nothing
    where
      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
  > Content-Type: text/plain
  >
  > password

  < HTTP/1.1 201 Created
-}
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) (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
	 when (isNothing userID)
             $ abort Forbidden [] Nothing

	 path ← getPathInfo
	 case path of
	   [name] → delUser (envAuthDB env) (T.pack name)
	   _      → abort BadRequest [] (Just "Invalid URI")
	 setStatus NoContent