gonito/Handler/ListChallenges.hs

98 lines
3.3 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 Data.Aeson
import Control.Lens hiding ((.=))
import Data.Swagger
import Data.Swagger.Lens
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])
return $ mempty
& paths .~
[ ("/api/list-challenges", mempty & get ?~ (mempty
& produces ?~ MimeList ["application/json"]
& description ?~ "Returns the list of all challenges"
& at 200 ?~ Inline listChallengesResponse))
]
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]
instance ToJSON (Entity Challenge) where
toJSON (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
]
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)
]
& 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
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 ()