content: {-# LANGUAGE NoImplicitPrelude #-}
  module Api.User (resource) where
  
  import Prelude.Compat
  
  import Control.Concurrent.STM (atomically, modifyTVar, readTVar)
  import Control.Monad.Error.Class (throwError)
  import Control.Monad.Reader (ReaderT, asks)
  import Control.Monad.Trans (liftIO)
  import Control.Monad.Trans.Except (ExceptT)
  import Data.Set (Set)
  import qualified Data.Foldable as F
  import qualified Data.Set      as Set
  import qualified Data.Text     as T
  
  import Rest
  import qualified Rest.Resource as R
  
  import ApiTypes (BlogApi, ServerData (..))
  import Type.User (User)
  import Type.UserInfo (UserInfo (..))
  import Type.UserSignupError (UserSignupError (..))
  import qualified Type.User     as User
  import qualified Type.UserInfo as UserInfo
  
  -- | User extends the root of the API with a reader containing the ways to identify a user in our URLs.
  -- Currently only by the user name.
  type WithUser = ReaderT User.Name BlogApi
  
  -- | Defines the /user api end-point.
  resource :: Resource BlogApi WithUser User.Name () Void
  resource = mkResourceReader
    { R.name   = "user" -- Name of the HTTP path segment.
    , R.schema = withListing () $ named [("name", singleBy T.pack)]
    , R.list   = const list -- requested by GET /user, gives a paginated listing of users.
    , R.create = Just create -- PUT /user creates a new user
    }
  
  list :: ListHandler BlogApi
  list = mkListing xmlJsonO handler
    where
      handler :: Range -> ExceptT Reason_ BlogApi [UserInfo]
      handler r = do
        usrs <- liftIO . atomically . readTVar =<< asks users
        return . map toUserInfo . take (count r) . drop (offset r) . Set.toList $ usrs
  
  -- | Convert a User into a representation that is safe to show to the public.
  toUserInfo :: User -> UserInfo
  toUserInfo u = UserInfo { UserInfo.name = User.name u }
  
  create :: Handler BlogApi
  create = mkInputHandler (xmlJsonE . xmlJsonO . xmlJsonI) handler
    where
      handler :: User -> ExceptT (Reason UserSignupError) BlogApi UserInfo
      handler usr = do
        usrs <- asks users
        merr <- liftIO . atomically $ do
          vu <- validUserName usr <$> readTVar usrs
          if not (validPassword usr)
            then return . Just $ domainReason InvalidPassword
            else if not vu
              then return . Just $ domainReason InvalidUserName
              else modifyTVar usrs (Set.insert usr) >> return Nothing
        maybe (return $ toUserInfo usr) throwError merr
  
  validPassword :: User.User -> Bool
  validPassword = (> 1) . T.length . User.password
  
  validUserName :: User -> Set User -> Bool
  validUserName u usrs =
    let un        = User.name u
        available = F.all ((un /=). User.name) usrs
        nonEmpty  = (> 1) . T.length $ un
    in available && nonEmpty
  