-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
5 changed files
with
163 additions
and
204 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,134 +1,43 @@ | ||
| {-# LANGUAGE DerivingVia #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TupleSections #-} | ||
| {-# LANGUAGE PatternSynonyms #-} | ||
|
|
||
| module Shields.Response | ||
| ( Colour, | ||
| renderColour, | ||
| Style, | ||
| renderStyle, | ||
| Logo, | ||
| renderLogo, | ||
| LogoWidth, | ||
| renderLogoWidth, | ||
| LogoPosition, | ||
| renderLogoPosition, | ||
| Seconds, | ||
| renderSeconds, | ||
| ShieldResponse (..), | ||
| ( ShieldResponse (..), | ||
| renderResponse, | ||
| defaultResponse, | ||
| ) | ||
| where | ||
|
|
||
| import Data.Coerce (coerce) | ||
| import Data.Maybe (catMaybes) | ||
| import Jsonifier | ||
| ( Json, | ||
| bool, | ||
| intNumber, | ||
| object, | ||
| textString, | ||
| writeJson, | ||
| import Data.Number.Scientific (fromWord64) | ||
| import Data.Text.Short (ShortText) | ||
| import Json | ||
| ( Value (Number, String), | ||
| object3, | ||
| pattern (:->), | ||
| ) | ||
| import PtrPoker.Write (Write) | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype Colour = Colour Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderColour :: Colour -> Json | ||
| renderColour = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype Style = Style Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderStyle :: Style -> Json | ||
| renderStyle = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype Logo = Logo Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderLogo :: Logo -> Json | ||
| renderLogo = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype LogoWidth = LogoWidth Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderLogoWidth :: LogoWidth -> Json | ||
| renderLogoWidth = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype LogoPosition = LogoPosition Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderLogoPosition :: LogoPosition -> Json | ||
| renderLogoPosition = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| newtype Seconds = Seconds Write | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderSeconds :: Seconds -> Json | ||
| renderSeconds = writeJson . coerce | ||
|
|
||
| -- | @since 1.0.0 | ||
| data ShieldResponse = ShieldResponse | ||
| newtype ShieldResponse = ShieldResponse | ||
| { -- | @since 1.0.0 | ||
| label :: {-# UNPACK #-} !Write, | ||
| -- | @since 1.0.0 | ||
| colour :: !(Maybe Colour), | ||
| -- | @since 1.0.0 | ||
| labelColour :: !(Maybe Colour), | ||
| -- | @since 1.0.0 | ||
| logoColour :: !(Maybe Colour), | ||
| -- | @since 1.0.0 | ||
| namedLogo :: !(Maybe Logo), | ||
| -- | @since 1.0.0 | ||
| logoSvg :: !(Maybe Logo), | ||
| -- | @since 1.0.0 | ||
| logoWidth :: !(Maybe LogoWidth), | ||
| -- | @since 1.0.0 | ||
| logoPosition :: !(Maybe LogoPosition), | ||
| -- | @since 1.0.0 | ||
| style :: !(Maybe Style), | ||
| -- | @since 1.0.0 | ||
| cacheSeconds :: !(Maybe Seconds) | ||
| label :: ShortText | ||
| } | ||
| deriving | ||
| ( -- | @since 1.0.0 | ||
| Eq, | ||
| -- | @since 1.0.0 | ||
| Show | ||
| ) | ||
| via ShortText | ||
|
|
||
| -- | @since 1.0.0 | ||
| defaultResponse :: ShieldResponse | ||
| defaultResponse = | ||
| ShieldResponse | ||
| { label = mempty, | ||
| colour = Nothing, | ||
| labelColour = Nothing, | ||
| logoColour = Nothing, | ||
| namedLogo = Nothing, | ||
| logoSvg = Nothing, | ||
| logoWidth = Nothing, | ||
| logoPosition = Nothing, | ||
| style = Nothing, | ||
| cacheSeconds = Nothing | ||
| } | ||
| defaultResponse = ShieldResponse "" | ||
|
|
||
| -- | @since 1.0.0 | ||
| renderResponse :: ShieldResponse -> Json | ||
| renderResponse sr = | ||
| object . catMaybes $ | ||
| [ pure ("schemaVersion", intNumber 1), | ||
| pure ("label", writeJson . label $ sr), | ||
| pure ("message", textString "Haskell Foundation"), | ||
| ("color",) . renderColour <$> colour sr, | ||
| ("labelColor",) . renderColour <$> labelColour sr, | ||
| pure ("isError", bool False), | ||
| ("namedLogo",) . renderLogo <$> namedLogo sr, | ||
| ("logoSvg",) . renderLogo <$> logoSvg sr, | ||
| ("logoColor",) . renderColour <$> logoColour sr, | ||
| ("logoWidth",) . renderLogoWidth <$> logoWidth sr, | ||
| ("logoPosition",) . renderLogoPosition <$> logoPosition sr, | ||
| ("style",) . renderStyle <$> style sr, | ||
| ("cacheSeconds",) . renderSeconds <$> cacheSeconds sr | ||
| ] | ||
| renderResponse :: ShieldResponse -> Value | ||
| renderResponse (ShieldResponse l) = | ||
| object3 | ||
| ("schemaVersion" :-> (Number . fromWord64 $ 1)) | ||
| ("label" :-> String l) | ||
| ("message" :-> String "Haskell Foundation") |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,115 @@ | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| module Main (main) where | ||
|
|
||
| import Data.Bytes (fromByteString) | ||
| import Data.CaseInsensitive (mk) | ||
| import Data.Foldable (find) | ||
| import Data.Number.Scientific (fromWord64) | ||
| import Json | ||
| ( Member (Member), | ||
| Value (Number, Object, String), | ||
| decode, | ||
| value, | ||
| ) | ||
| import Shields.Api (api) | ||
| import Snap.Core | ||
| ( Method (HEAD), | ||
| getHeader, | ||
| rspStatus, | ||
| rspStatusReason, | ||
| ) | ||
| import Snap.Test | ||
| ( RequestBuilder, | ||
| RequestType (RequestWithRawBody), | ||
| assertSuccess, | ||
| get, | ||
| getResponseBody, | ||
| runHandler, | ||
| setRequestPath, | ||
| setRequestType, | ||
| ) | ||
| import Test.Tasty (TestTree, defaultMain, testGroup) | ||
| import Test.Tasty.HUnit (assertEqual, testCase) | ||
| import Prelude hiding (lookup) | ||
|
|
||
| main :: IO () | ||
| main = defaultMain tests | ||
|
|
||
| tests :: TestTree | ||
| tests = | ||
| testGroup | ||
| "Responses" | ||
| [ testCase "Get, /heartbeat" $ do | ||
| resp <- runHandler getHeartbeat api | ||
| assertSuccess resp | ||
| assertEqual "Status reason is 'Ok'" "Ok" . rspStatusReason $ resp, | ||
| testCase "Head, /heartbeat" $ do | ||
| resp <- runHandler headHeartbeat api | ||
| assertSuccess resp | ||
| assertEqual "Status reason is 'Ok'" "Ok" . rspStatusReason $ resp, | ||
| testCase "Get, /" $ do | ||
| resp <- runHandler getTop api | ||
| assertEqual "Status code is 200" 200 . rspStatus $ resp | ||
| assertEqual "Content type is JSON" (Just "application/json") . getHeader (mk "Content-Type") $ resp | ||
| parsed <- decode . fromByteString <$> getResponseBody resp | ||
| assertEqual | ||
| "Content is a three-attribute object" | ||
| (Right . Just $ 3) | ||
| (checkObject <$> parsed) | ||
| assertEqual | ||
| "schemaVersion attribute has value 1" | ||
| (Right . Just . Number . fromWord64 $ 1) | ||
| (checkSchemaVersion <$> parsed) | ||
| assertEqual | ||
| "label attribute has value ''" | ||
| (Right . Just . String $ "") | ||
| (checkLabel <$> parsed) | ||
| assertEqual | ||
| "message attribute has value 'Haskell Foundation'" | ||
| (Right . Just . String $ "Haskell Foundation") | ||
| (checkMessage <$> parsed) | ||
| ] | ||
|
|
||
| -- Helpers | ||
|
|
||
| checkObject :: Value -> Maybe Int | ||
| checkObject = \case | ||
| Object mems -> Just . length $ mems | ||
| _ -> Nothing | ||
|
|
||
| checkSchemaVersion :: Value -> Maybe Value | ||
| checkSchemaVersion = \case | ||
| Object mems -> value <$> find go mems | ||
| _ -> Nothing | ||
| where | ||
| go :: Member -> Bool | ||
| go (Member k _) = k == "schemaVersion" | ||
|
|
||
| checkLabel :: Value -> Maybe Value | ||
| checkLabel = \case | ||
| Object mems -> value <$> find go mems | ||
| _ -> Nothing | ||
| where | ||
| go :: Member -> Bool | ||
| go (Member k _) = k == "label" | ||
|
|
||
| checkMessage :: Value -> Maybe Value | ||
| checkMessage = \case | ||
| Object mems -> value <$> find go mems | ||
| _ -> Nothing | ||
| where | ||
| go :: Member -> Bool | ||
| go (Member k _) = k == "message" | ||
|
|
||
| getTop :: RequestBuilder IO () | ||
| getTop = get "/" mempty | ||
|
|
||
| getHeartbeat :: RequestBuilder IO () | ||
| getHeartbeat = get "/heartbeat" mempty | ||
|
|
||
| headHeartbeat :: RequestBuilder IO () | ||
| headHeartbeat = do | ||
| setRequestType . RequestWithRawBody HEAD $ "" | ||
| setRequestPath "/heartbeat" |
Oops, something went wrong.