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
type WithUser = ReaderT User.Name BlogApi
resource :: Resource BlogApi WithUser User.Name () Void
resource = mkResourceReader
{ R.name = "user"
, R.schema = withListing () $ named [("name", singleBy T.pack)]
, R.list = const list
, R.create = Just create
}
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
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