gonito/Handler/ListChallenges.hs

122 lines
4.8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
2015-09-04 23:23:32 +02:00
module Handler.ListChallenges where
import Import hiding (get, fromList, Proxy)
import Data.HashMap.Strict.InsOrd (fromList)
import Data.Proxy
import Control.Lens hiding ((.=))
import Data.Swagger
import Data.Swagger.Declare
2015-09-04 23:23:32 +02:00
mainCondition :: [Filter Challenge]
mainCondition = [ChallengeArchived !=. Just True]
2015-09-04 23:23:32 +02:00
getListChallengesR :: Handler Html
getListChallengesR = generalListChallenges mainCondition
declareListChallengesSwagger :: Declare (Definitions Schema) Swagger
declareListChallengesSwagger = do
-- param schemas
listChallengesResponse <- declareResponse (Proxy :: Proxy [Entity Challenge])
2021-02-15 18:27:10 +01:00
challengeInfoResponse <- declareResponse (Proxy :: Proxy (Entity Challenge))
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
return $ mempty
& paths .~
[ ("/api/list-challenges", mempty & get ?~ (mempty
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns the list of all challenges"
2021-02-15 18:27:10 +01:00
& at 200 ?~ Inline listChallengesResponse)),
("/api/challenge-info/{challengeName}",
mempty & get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "challengeName"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ challengeNameSchema) ]
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns metadata for a specific challenge"
& at 200 ?~ Inline challengeInfoResponse))
]
listChallengesApi :: Swagger
listChallengesApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareListChallengesSwagger mempty
getListChallengesJsonR :: Handler Value
getListChallengesJsonR = generalListChallengesJson mainCondition
2019-03-20 16:31:08 +01:00
getListArchivedChallengesR :: Handler Html
getListArchivedChallengesR = generalListChallenges [ChallengeArchived ==. Just True]
2021-02-08 20:52:12 +01:00
imageUrl :: Entity Challenge -> Maybe (Route App)
imageUrl (Entity challengeId challenge) =
case challengeImage challenge of
Just _ -> Just $ ChallengeImageR challengeId
Nothing -> Nothing
instance ToJSON (Entity Challenge) where
2021-02-08 20:52:12 +01:00
toJSON chEnt@(Entity _ ch) = object
2020-10-15 22:27:16 +02:00
[ "name" .= challengeName ch
, "title" .= challengeTitle ch
, "description" .= challengeDescription ch
2020-10-15 22:27:16 +02:00
, "starred" .= challengeStarred ch
, "archived" .= challengeArchived ch
2021-02-08 20:52:12 +01:00
, "imageUrl" .= (("/" <>) <$> intercalate "/" <$> fst <$> renderRoute <$> imageUrl chEnt)
]
instance ToSchema (Entity Challenge) where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (Proxy :: Proxy String)
booleanSchema <- declareSchemaRef (Proxy :: Proxy Bool)
return $ NamedSchema (Just "Challenge") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema)
, ("title", stringSchema)
, ("description", stringSchema)
, ("starred", booleanSchema)
, ("archived", booleanSchema)
2021-02-08 20:52:12 +01:00
, ("imageUrl", stringSchema)
]
& required .~ [ "name", "title", "description", "starred", "archived" ]
generalListChallengesJson :: [Filter Challenge] -> Handler Value
generalListChallengesJson filterExpr = do
challenges <- getChallenges filterExpr
return $ toJSON challenges
2020-10-12 07:17:48 +02:00
generalListChallenges :: [Filter Challenge] -> Handler Html
2019-03-20 16:31:08 +01:00
generalListChallenges filterExpr = do
2020-10-12 07:17:48 +02:00
challenges <- getChallenges filterExpr
2015-09-04 23:23:32 +02:00
defaultLayout $ do
setTitle "List challenges"
$(widgetFile "list-challenges")
2020-10-12 07:17:48 +02:00
getChallenges :: [Filter Challenge] -> Handler [Entity Challenge]
getChallenges filterExpr = runDB $ selectList filterExpr [Desc ChallengeStarred, Desc ChallengeStamp]
listChallengesCore :: [Entity Challenge] -> Widget
2015-09-04 23:23:32 +02:00
listChallengesCore challenges = $(widgetFile "list-challenges-core")
2018-01-18 08:21:06 +01:00
2021-02-15 18:27:10 +01:00
getChallengeInfoJsonR :: Text -> Handler Value
getChallengeInfoJsonR challengeName = do
entCh <- runDB $ getBy404 $ UniqueName challengeName
return $ toJSON entCh
2018-01-18 08:21:06 +01:00
getChallengeImageR :: ChallengeId -> Handler Html
getChallengeImageR challengeId = do
challenge <- runDB $ get404 challengeId
case challengeImage challenge of
Just image -> do
addHeader "Content-Disposition" "attachment; filename=\"image.png\""
sendResponse (typePng, toContent image)
Nothing -> sendResponseStatus status202 ()