module Api.User (resource) where
import Control.Applicative ((<$>))
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