aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-22 11:33:34 +03:00
Code Issues Projects Releases Wiki Activity

Make HLint usable (#367)

Browse Source 
* Apply Hlint's suggestions and suppress others

* Add hints about qualified imports and CPP
This commit is contained in:
Artyom Kazak 2019-08-11 15:57:49 +03:00 committed by mergify[bot]
parent 612266fe6d
commit 94e0939d7b
19 changed files with 446 additions and 415 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
.hlint.yaml
View File

@ -1,19 +1,46 @@
# Help Hlint parse our code
- arguments:
- -XTypeApplications
# Force qualified imports to be imported consistently.
- modules:
# Common modules from the Haskell ecosystem. The chosen abbreviations
# are the most common or almost the most common, as per Hackage stats.
# For consistency, Data.ByteString and Data.ByteString.Lazy are
# abbreviated as BS and BSL respectively, even though B and BL are
# somewhat more common.
- { name: Data.ByteString, as: BS }
- { name: Data.ByteString.Lazy, as: BSL }
- { name: Data.ByteString.Char8, as: BSC }
- { name: Data.ByteString.Lazy.Char8, as: BSLC }
- { name: Data.Text, as: T }
- { name: Data.Text.Lazy, as: TL }
- { name: Data.HashMap.Strict, as: HM }
- { name: Data.HashMap.Lazy, as: HML }
# Less common modules deserve longer names.
- { name: Data.Aeson, as: Aeson }
- { name: Data.Yaml, as: Yaml }
- { name: Data.List.NonEmpty, as: NonEmpty }
# Forbid '-XCPP', which is poorly supported by code formatting tools. If a
# need to use '-XCPP' arises in the future, it should be contained within a
# single module named 'Compat'.
- extensions:
- { name: CPP, within: [] }
# Hints we don't like
- ignore: {name: 'Redundant do'}
- ignore: {name: 'Redundant bracket'}
- ignore: {name: 'Redundant $'}
- ignore: {name: 'Redundant flip'}
- ignore: {name: 'Move brackets to avoid $'}
- ignore: {name: 'Eta reduce'}
- ignore: {name: 'Avoid lambda'}
- ignore: {name: 'Use camelCase'}
- ignore: {name: 'Use const'}
- ignore: {name: 'Use if'}
- ignore: {name: 'Use notElem'}
- ignore: {name: 'Use fromMaybe'}
- ignore: {name: 'Use maybe'}
- ignore: {name: 'Use fmap'}
- ignore: {name: 'Use foldl'}
- ignore: {name: 'Use :'}
- ignore: {name: 'Use ++'}
- ignore: {name: 'Use ||'}
- ignore: {name: 'Use &&'}
@ -26,3 +53,6 @@
- ignore: {name: 'Use newtype instead of data'}
- ignore: {name: 'Redundant lambda'}
- ignore: {name: 'Use section'}
# Hints we won't be fixing yet
- ignore: {name: 'Reduce duplication'}

1
back/src/Guide/Api/Error.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

152
back/src/Guide/Api/Types.hs
View File

@ -72,7 +72,7 @@ import Guide.Search
import Guide.Types.Core as G
import Guide.Utils (Uid (..), Url, fields)
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
import Data.Swagger as S
----------------------------------------------------------------------------
@ -320,13 +320,13 @@ instance ToSchema CTraitType where
other -> error ("CTraitType schema: unknown value " <> show other)
}
instance A.ToJSON CTraitType where
instance Aeson.ToJSON CTraitType where
toJSON = \case
CPro -> "Pro"
CCon -> "Con"
instance A.FromJSON CTraitType where
parseJSON = A.withText "CTraitType" $ \case
instance Aeson.FromJSON CTraitType where
parseJSON = Aeson.withText "CTraitType" $ \case
"Pro" -> pure CPro
"Con" -> pure CCon
other -> fail ("unknown trait type " <> show other)
@ -347,13 +347,13 @@ instance ToSchema CDirection where
other -> error ("CDirection schema: unknown value " <> show other)
}
instance A.ToJSON CDirection where
instance Aeson.ToJSON CDirection where
toJSON = \case
DirectionUp -> "up"
DirectionDown -> "down"
instance A.FromJSON CDirection where
parseJSON = A.withText "CDirection" $ \case
instance Aeson.FromJSON CDirection where
parseJSON = Aeson.withText "CDirection" $ \case
"up" -> pure DirectionUp
"down" -> pure DirectionDown
other -> fail ("unknown direction " <> show other)
@ -369,11 +369,11 @@ data CCreateItem = CCreateItem
, cciLink :: Maybe Url
} deriving (Show, Generic)
instance A.ToJSON CCreateItem where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CCreateItem where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CCreateItem where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CCreateItem where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CCreateItem where
declareNamedSchema p = do
@ -395,11 +395,11 @@ data CCreateTrait = CCreateTrait
, cctContent :: Text
} deriving (Show, Generic)
instance A.ToJSON CCreateTrait where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CCreateTrait where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CCreateTrait where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CCreateTrait where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CCreateTrait where
declareNamedSchema = genericDeclareNamedSchema schemaOptions
@ -413,11 +413,11 @@ data CMove = CMove
{ cmDirection :: CDirection
} deriving (Show, Eq, Generic)
instance A.ToJSON CMove where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CMove where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CMove where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CMove where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CMove where
declareNamedSchema = genericDeclareNamedSchema schemaOptions
@ -437,11 +437,11 @@ data CCategoryInfo = CCategoryInfo
}
deriving (Show, Generic)
instance A.ToJSON CCategoryInfo where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CCategoryInfo where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CCategoryInfo where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CCategoryInfo where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CCategoryInfo where
declareNamedSchema p = do
@ -487,11 +487,11 @@ data CCategoryFull = CCategoryFull
}
deriving (Show, Generic)
instance A.ToJSON CCategoryFull where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CCategoryFull where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CCategoryFull where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CCategoryFull where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CCategoryFull where
declareNamedSchema p = do
@ -533,11 +533,11 @@ data CCategoryInfoEdit = CCategoryInfoEdit
}
deriving (Show, Generic)
instance A.ToJSON CCategoryInfoEdit where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CCategoryInfoEdit where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CCategoryInfoEdit where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CCategoryInfoEdit where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CCategoryInfoEdit where
declareNamedSchema p = do
@ -567,8 +567,8 @@ data CItemInfo = CItemInfo
, ciiLink :: Maybe Url
} deriving (Show, Generic)
instance A.ToJSON CItemInfo where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CItemInfo where
toJSON = Aeson.genericToJSON jsonOptions
instance ToSchema CItemInfo where
declareNamedSchema p = do
@ -612,18 +612,18 @@ data CItemInfoEdit = CItemInfoEdit
} deriving (Show, Generic)
-- Manual instances because we want special behavior for Maybe
instance A.ToJSON CItemInfoEdit where
toJSON ciie = A.object $ catMaybes
[ ("name" A..=) <$> ciieName ciie
, ("hackage" A..=) <$> ciieHackage ciie
, ("link" A..=) <$> ciieLink ciie
instance Aeson.ToJSON CItemInfoEdit where
toJSON ciie = Aeson.object $ catMaybes
[ ("name" Aeson..=) <$> ciieName ciie
, ("hackage" Aeson..=) <$> ciieHackage ciie
, ("link" Aeson..=) <$> ciieLink ciie
]
instance A.FromJSON CItemInfoEdit where
parseJSON = A.withObject "CItemInfoEdit" $ \o -> do
ciieName' <- o A..:! "name"
ciieHackage' <- o A..:! "hackage"
ciieLink' <- o A..:! "link"
instance Aeson.FromJSON CItemInfoEdit where
parseJSON = Aeson.withObject "CItemInfoEdit" $ \o -> do
ciieName' <- o Aeson..:! "name"
ciieHackage' <- o Aeson..:! "hackage"
ciieLink' <- o Aeson..:! "link"
return CItemInfoEdit
{ ciieName = ciieName'
, ciieHackage = ciieHackage'
@ -659,11 +659,11 @@ data CItemFull = CItemFull
, cifToc :: [CTocHeading]
} deriving (Show, Generic)
instance A.ToJSON CItemFull where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CItemFull where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CItemFull where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CItemFull where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CItemFull where
declareNamedSchema p = do
@ -709,11 +709,11 @@ data CTrait = CTrait
, ctContent :: CMarkdown
} deriving (Show, Generic)
instance A.ToJSON CTrait where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CTrait where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CTrait where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CTrait where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CTrait where
declareNamedSchema = genericDeclareNamedSchema schemaOptions
@ -735,11 +735,11 @@ data CMarkdown = CMarkdown
, cmdHtml :: Text
} deriving (Show, Generic)
instance A.ToJSON CMarkdown where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CMarkdown where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CMarkdown where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CMarkdown where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CMarkdown where
declareNamedSchema p = do
@ -792,11 +792,11 @@ data CTocHeading = CTocHeading
, cthSubheadings :: [CTocHeading]
} deriving (Show, Generic)
instance A.ToJSON CTocHeading where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CTocHeading where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CTocHeading where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CTocHeading where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CTocHeading where
declareNamedSchema p = do
@ -823,11 +823,11 @@ data CTextEdit = CTextEdit
, cteModified :: Text
} deriving (Show, Generic)
instance A.ToJSON CTextEdit where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CTextEdit where
toJSON = Aeson.genericToJSON jsonOptions
instance A.FromJSON CTextEdit where
parseJSON = A.genericParseJSON jsonOptions
instance Aeson.FromJSON CTextEdit where
parseJSON = Aeson.genericParseJSON jsonOptions
instance ToSchema CTextEdit where
declareNamedSchema p = do
@ -850,8 +850,8 @@ data CMergeConflict = CMergeConflict
, cmcMerged :: Text
} deriving (Eq, Show, Generic)
instance A.ToJSON CMergeConflict where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CMergeConflict where
toJSON = Aeson.genericToJSON jsonOptions
instance ToSchema CMergeConflict where
declareNamedSchema p = do
@ -877,15 +877,15 @@ data CSearchResult
| CSRItemResult CSRItem
deriving (Show, Generic)
instance A.ToJSON CSearchResult where
instance Aeson.ToJSON CSearchResult where
toJSON = \case
CSRCategoryResult cat -> A.object
[ "tag" A..= ("Category" :: Text)
, "contents" A..= cat
CSRCategoryResult cat -> Aeson.object
[ "tag" Aeson..= ("Category" :: Text)
, "contents" Aeson..= cat
]
CSRItemResult item -> A.object
[ "tag" A..= ("Item" :: Text)
, "contents" A..= item
CSRItemResult item -> Aeson.object
[ "tag" Aeson..= ("Item" :: Text)
, "contents" Aeson..= item
]
instance ToSchema CSearchResult where
@ -910,8 +910,8 @@ data CSRCategory = CSRCategory
, csrcDescription :: CMarkdown
} deriving (Show, Generic)
instance A.ToJSON CSRCategory where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CSRCategory where
toJSON = Aeson.genericToJSON jsonOptions
instance ToSchema CSRCategory where
declareNamedSchema = genericDeclareNamedSchema schemaOptions
@ -928,8 +928,8 @@ data CSRItem = CSRItem
, csriEcosystem :: Maybe CMarkdown
} deriving (Show, Generic)
instance A.ToJSON CSRItem where
toJSON = A.genericToJSON jsonOptions
instance Aeson.ToJSON CSRItem where
toJSON = Aeson.genericToJSON jsonOptions
instance ToSchema CSRItem where
declareNamedSchema = genericDeclareNamedSchema schemaOptions

16
back/src/Guide/Api/Utils.hs
View File

@ -1,9 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -11,6 +8,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Guide.Api.Utils
(
@ -103,12 +102,12 @@ instance FromHttpApiData IP where
instance (HasSwagger api) => HasSwagger (RequestDetails :> api) where
toSwagger _ = toSwagger (Proxy :: Proxy api)
instance (HasServer api context)
=> HasServer (RequestDetails :> api) context where
instance (HasServer api context) => HasServer (RequestDetails :> api) context where
type ServerT (RequestDetails :> api) m = RequestDetails -> ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
hoistServerWithContext _ pc nt s =
hoistServerWithContext (Proxy :: Proxy api) pc nt . s
route Proxy context subserver = route (Proxy :: Proxy api) context $
subserver `addHeaderCheck` withRequest getRequestDetails
@ -127,8 +126,9 @@ instance (HasServer api context)
lookupName headerName = lookup headerName (requestHeaders req)
getHeader :: FromHttpApiData a => NHTH.HeaderName -> Maybe a
getHeader headerName = join $
(either (\_ -> Nothing) Just) . parseHeader <$> lookupName headerName
getHeader headerName =
(either (\_ -> Nothing) Just) . parseHeader =<<
lookupName headerName
getIp :: Maybe ByteString -> Maybe IP
getIp mBody = case mBody of

18
back/src/Guide/Archival.hs
View File

@ -21,7 +21,7 @@ import Network.HTTP.Client
import Guide.Utils
-- JSON
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
-- | Get status of a link on archive.org.
--
@ -35,8 +35,8 @@ getArchivalStatus manager lnk =
fromJsonWith responseParser . responseBody <$!> httpLbs req manager
where
waybackUrl = "http://archive.org/wayback/available"
responseParser = A.withObject "archive.org response" $
(A..: "archived_snapshots") >=> (A..: "closest")
responseParser = Aeson.withObject "archive.org response" $
(Aeson..: "archived_snapshots") >=> (Aeson..: "closest")
data ArchivalStatus = ArchivalStatus {
asAvailable :: Bool, -- ^ Whether the link is available
@ -52,11 +52,11 @@ data ArchivalStatus = ArchivalStatus {
-- , "available": true
-- , "url": "http://web.archive.org/web/20170819042701/http://example.com"
-- , "timestamp": "20170819042701" }
instance A.FromJSON ArchivalStatus where
parseJSON = A.withObject "ArchivalStatus" $ \o -> do
asAvailable <- o A..: "available"
asUrl <- o A..: "url"
asStatus <- o A..: "status"
asTimestamp <- o A..: "timestamp" >>=
instance Aeson.FromJSON ArchivalStatus where
parseJSON = Aeson.withObject "ArchivalStatus" $ \o -> do
asAvailable <- o Aeson..: "available"
asUrl <- o Aeson..: "url"
asStatus <- o Aeson..: "status"
asTimestamp <- o Aeson..: "timestamp" >>=
parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S"
pure ArchivalStatus{..}

24
back/src/Guide/Markdown.hs
View File

@ -53,7 +53,7 @@ import Data.SafeCopy
import Guide.Utils
import qualified CMark as MD
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.Set as S
import qualified Data.Text as T
@ -312,17 +312,17 @@ instance Show MarkdownTree where
show = show . markdownTreeSource
deriving instance Show Heading
instance A.ToJSON MarkdownInline where
toJSON md = A.object [
"text" A..= markdownInlineSource md,
"html" A..= toText (markdownInlineHtml md) ]
instance A.ToJSON MarkdownBlock where
toJSON md = A.object [
"text" A..= markdownBlockSource md,
"html" A..= toText (markdownBlockHtml md) ]
instance A.ToJSON MarkdownTree where
toJSON md = A.object [
"text" A..= markdownTreeSource md ]
instance Aeson.ToJSON MarkdownInline where
toJSON md = Aeson.object [
"text" Aeson..= markdownInlineSource md,
"html" Aeson..= toText (markdownInlineHtml md) ]
instance Aeson.ToJSON MarkdownBlock where
toJSON md = Aeson.object [
"text" Aeson..= markdownBlockSource md,
"html" Aeson..= toText (markdownBlockHtml md) ]
instance Aeson.ToJSON MarkdownTree where
toJSON md = Aeson.object [
"text" Aeson..= markdownTreeSource md ]
instance ToHtml MarkdownInline where
toHtmlRaw = toHtml

2
back/src/Guide/Matomo.hs
View File

@ -60,7 +60,7 @@ postMatomo Matomo{..} = push "postMatomo" $ do
action_name = Just (BS.intercalate "/" ["Haskell", "Edit", showConstructor mTag])
showConstructor :: Edit -> ByteString
showConstructor = toByteString
. drop (length ("Edit'" :: String))
. drop (length ("Edit" :: String))
. takeWhile (not . isSpace)
. show
piwik :: Url -> String

44
back/src/Guide/ServerStuff.hs
View File

@ -99,85 +99,85 @@ addEdit ed = do
-- been deleted; this should change.
undoEdit :: (MonadIO m, HasSpock m, SpockState m ~ ServerState)
=> Edit -> m (Either String ())
undoEdit (Edit'AddCategory catId _ _) = do
undoEdit (EditAddCategory catId _ _) = do
void <$> dbUpdate (DeleteCategory catId)
undoEdit (Edit'AddItem _catId itemId _) = do
undoEdit (EditAddItem _catId itemId _) = do
void <$> dbUpdate (DeleteItem itemId)
undoEdit (Edit'AddPro itemId traitId _) = do
undoEdit (EditAddPro itemId traitId _) = do
void <$> dbUpdate (DeleteTrait itemId traitId)
undoEdit (Edit'AddCon itemId traitId _) = do
undoEdit (EditAddCon itemId traitId _) = do
void <$> dbUpdate (DeleteTrait itemId traitId)
undoEdit (Edit'SetCategoryTitle catId old new) = do
undoEdit (EditSetCategoryTitle catId old new) = do
now <- categoryTitle <$> dbQuery (GetCategory catId)
if now /= new
then return (Left "title has been changed further")
else Right () <$ dbUpdate (SetCategoryTitle catId old)
undoEdit (Edit'SetCategoryGroup catId old new) = do
undoEdit (EditSetCategoryGroup catId old new) = do
now <- categoryGroup <$> dbQuery (GetCategory catId)
if now /= new
then return (Left "group has been changed further")
else Right () <$ dbUpdate (SetCategoryGroup catId old)
undoEdit (Edit'SetCategoryStatus catId old new) = do
undoEdit (EditSetCategoryStatus catId old new) = do
now <- categoryStatus <$> dbQuery (GetCategory catId)
if now /= new
then return (Left "status has been changed further")
else Right () <$ dbUpdate (SetCategoryStatus catId old)
undoEdit (Edit'ChangeCategoryEnabledSections catId toEnable toDisable) = do
undoEdit (EditChangeCategoryEnabledSections catId toEnable toDisable) = do
enabledNow <- categoryEnabledSections <$> dbQuery (GetCategory catId)
if any (`elem` enabledNow) toDisable || any (`notElem` enabledNow) toEnable
then return (Left "enabled-sections has been changed further")
else Right () <$ dbUpdate (ChangeCategoryEnabledSections catId toDisable toEnable)
undoEdit (Edit'SetCategoryNotes catId old new) = do
undoEdit (EditSetCategoryNotes catId old new) = do
now <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId)
if now /= new
then return (Left "notes have been changed further")
else Right () <$ dbUpdate (SetCategoryNotes catId old)
undoEdit (Edit'SetItemName itemId old new) = do
undoEdit (EditSetItemName itemId old new) = do
now <- itemName <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "name has been changed further")
else Right () <$ dbUpdate (SetItemName itemId old)
undoEdit (Edit'SetItemLink itemId old new) = do
undoEdit (EditSetItemLink itemId old new) = do
now <- itemLink <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "link has been changed further")
else Right () <$ dbUpdate (SetItemLink itemId old)
undoEdit (Edit'SetItemGroup _ _ _) = do
undoEdit EditSetItemGroup{} = do
return (Left "groups are not supported anymore")
undoEdit (Edit'SetItemHackage itemId old new) = do
undoEdit (EditSetItemHackage itemId old new) = do
now <- itemHackage <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "Hackage name has been changed further")
else Right () <$ dbUpdate (SetItemHackage itemId old)
undoEdit (Edit'SetItemSummary itemId old new) = do
undoEdit (EditSetItemSummary itemId old new) = do
now <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "description has been changed further")
else Right () <$ dbUpdate (SetItemSummary itemId old)
undoEdit (Edit'SetItemNotes itemId old new) = do
undoEdit (EditSetItemNotes itemId old new) = do
now <- markdownTreeSource . itemNotes <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "notes have been changed further")
else Right () <$ dbUpdate (SetItemNotes itemId old)
undoEdit (Edit'SetItemEcosystem itemId old new) = do
undoEdit (EditSetItemEcosystem itemId old new) = do
now <- markdownBlockSource . itemEcosystem <$> dbQuery (GetItem itemId)
if now /= new
then return (Left "ecosystem has been changed further")
else Right () <$ dbUpdate (SetItemEcosystem itemId old)
undoEdit (Edit'SetTraitContent itemId traitId old new) = do
undoEdit (EditSetTraitContent itemId traitId old new) = do
now <- markdownInlineSource . traitContent <$> dbQuery (GetTrait itemId traitId)
if now /= new
then return (Left "trait has been changed further")
else Right () <$ dbUpdate (SetTraitContent itemId traitId old)
undoEdit (Edit'DeleteCategory catId pos) = do
undoEdit (EditDeleteCategory catId pos) = do
dbUpdate (RestoreCategory catId pos)
undoEdit (Edit'DeleteItem itemId pos) = do
undoEdit (EditDeleteItem itemId pos) = do
dbUpdate (RestoreItem itemId pos)
undoEdit (Edit'DeleteTrait itemId traitId pos) = do
undoEdit (EditDeleteTrait itemId traitId pos) = do
dbUpdate (RestoreTrait itemId traitId pos)
undoEdit (Edit'MoveItem itemId direction) = do
undoEdit (EditMoveItem itemId direction) = do
Right () <$ dbUpdate (MoveItem itemId (not direction))
undoEdit (Edit'MoveTrait itemId traitId direction) = do
undoEdit (EditMoveTrait itemId traitId direction) = do
Right () <$ dbUpdate (MoveTrait itemId traitId (not direction))
----------------------------------------------------------------------------

44
back/src/Guide/State.hs
View File

@ -356,7 +356,7 @@ addCategory catId title' group' created' = do
categoryItems = [],
categoryItemsDeleted = [] }
_categories %= (newCategory :)
let edit = Edit'AddCategory catId title' group'
let edit = EditAddCategory catId title' group'
return (edit, newCategory)
addItem
@ -381,7 +381,7 @@ addItem catId itemId name' created' = do
in toMarkdownTree pref "",
itemLink = Nothing}
categoryById catId . _categoryItems %= (++ [newItem])
let edit = Edit'AddItem catId itemId name'
let edit = EditAddItem catId itemId name'
return (edit, newItem)
addPro
@ -392,7 +392,7 @@ addPro
addPro itemId traitId text' = do
let newTrait = Trait traitId (toMarkdownInline text')
itemById itemId . _itemPros %= (++ [newTrait])
let edit = Edit'AddPro itemId traitId text'
let edit = EditAddPro itemId traitId text'
return (edit, newTrait)
addCon
@ -403,7 +403,7 @@ addCon
addCon itemId traitId text' = do
let newTrait = Trait traitId (toMarkdownInline text')
itemById itemId . _itemCons %= (++ [newTrait])
let edit = Edit'AddCon itemId traitId text'
let edit = EditAddCon itemId traitId text'
return (edit, newTrait)
-- set
@ -419,25 +419,25 @@ setGlobalState = (id .=)
setCategoryTitle :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
setCategoryTitle catId title' = do
oldTitle <- categoryById catId . _categoryTitle <<.= title'
let edit = Edit'SetCategoryTitle catId oldTitle title'
let edit = EditSetCategoryTitle catId oldTitle title'
(edit,) <$> use (categoryById catId)
setCategoryGroup :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
setCategoryGroup catId group' = do
oldGroup <- categoryById catId . _categoryGroup <<.= group'
let edit = Edit'SetCategoryGroup catId oldGroup group'
let edit = EditSetCategoryGroup catId oldGroup group'
(edit,) <$> use (categoryById catId)
setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
setCategoryNotes catId notes' = do
oldNotes <- categoryById catId . _categoryNotes <<.= toMarkdownBlock notes'
let edit = Edit'SetCategoryNotes catId (markdownBlockSource oldNotes) notes'
let edit = EditSetCategoryNotes catId (markdownBlockSource oldNotes) notes'
(edit,) <$> use (categoryById catId)
setCategoryStatus :: Uid Category -> CategoryStatus -> Acid.Update GlobalState (Edit, Category)
setCategoryStatus catId status' = do
oldStatus <- categoryById catId . _categoryStatus <<.= status'
let edit = Edit'SetCategoryStatus catId oldStatus status'
let edit = EditSetCategoryStatus catId oldStatus status'
(edit,) <$> use (categoryById catId)
changeCategoryEnabledSections
@ -448,32 +448,32 @@ changeCategoryEnabledSections
changeCategoryEnabledSections catId toEnable toDisable = do
categoryById catId . _categoryEnabledSections %= \sections ->
(sections <> toEnable) S.\\ toDisable
let edit = Edit'ChangeCategoryEnabledSections catId toEnable toDisable
let edit = EditChangeCategoryEnabledSections catId toEnable toDisable
(edit,) <$> use (categoryById catId)
setItemName :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemName itemId name' = do
oldName <- itemById itemId . _itemName <<.= name'
let edit = Edit'SetItemName itemId oldName name'
let edit = EditSetItemName itemId oldName name'
(edit,) <$> use (itemById itemId)
setItemLink :: Uid Item -> Maybe Url -> Acid.Update GlobalState (Edit, Item)
setItemLink itemId link' = do
oldLink <- itemById itemId . _itemLink <<.= link'
let edit = Edit'SetItemLink itemId oldLink link'
let edit = EditSetItemLink itemId oldLink link'
(edit,) <$> use (itemById itemId)
setItemHackage :: Uid Item -> Maybe Text -> Acid.Update GlobalState (Edit, Item)
setItemHackage itemId hackage' = do
oldName <- itemById itemId . _itemHackage <<.= hackage'
let edit = Edit'SetItemHackage itemId oldName hackage'
let edit = EditSetItemHackage itemId oldName hackage'
(edit,) <$> use (itemById itemId)
setItemSummary :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemSummary itemId description' = do
oldDescr <- itemById itemId . _itemSummary <<.=
toMarkdownBlock description'
let edit = Edit'SetItemSummary itemId
let edit = EditSetItemSummary itemId
(markdownBlockSource oldDescr) description'
(edit,) <$> use (itemById itemId)
@ -481,13 +481,13 @@ setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemNotes itemId notes' = do
let pref = "item-notes-" <> uidToText itemId <> "-"
oldNotes <- itemById itemId . _itemNotes <<.= toMarkdownTree pref notes'
let edit = Edit'SetItemNotes itemId (markdownTreeSource oldNotes) notes'
let edit = EditSetItemNotes itemId (markdownTreeSource oldNotes) notes'
(edit,) <$> use (itemById itemId)
setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemEcosystem itemId ecosystem' = do
oldEcosystem <- itemById itemId . _itemEcosystem <<.= toMarkdownBlock ecosystem'
let edit = Edit'SetItemEcosystem itemId
let edit = EditSetItemEcosystem itemId
(markdownBlockSource oldEcosystem) ecosystem'
(edit,) <$> use (itemById itemId)
@ -495,7 +495,7 @@ setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edi
setTraitContent itemId traitId content' = do
oldContent <- itemById itemId . traitById traitId . _traitContent <<.=
toMarkdownInline content'
let edit = Edit'SetTraitContent itemId traitId
let edit = EditSetTraitContent itemId traitId
(markdownInlineSource oldContent) content'
(edit,) <$> use (itemById itemId . traitById traitId)
@ -513,7 +513,7 @@ deleteCategory catId = do
Just categoryPos -> do
_categories %= deleteAt categoryPos
_categoriesDeleted %= (category:)
return (Right (Edit'DeleteCategory catId categoryPos))
return (Right (EditDeleteCategory catId categoryPos))
deleteItem :: Uid Item -> Acid.Update GlobalState (Either String Edit)
deleteItem itemId = do
@ -532,7 +532,7 @@ deleteItem itemId = do
Just itemPos -> do
categoryLens . _categoryItems %= deleteAt itemPos
categoryLens . _categoryItemsDeleted %= (item:)
return (Right (Edit'DeleteItem itemId itemPos))
return (Right (EditDeleteItem itemId itemPos))
deleteTrait :: Uid Item -> Uid Trait -> Acid.Update GlobalState (Either String Edit)
deleteTrait itemId traitId = do
@ -558,7 +558,7 @@ deleteTrait itemId traitId = do
Just traitPos -> do
itemLens . _itemPros %= deleteAt traitPos
itemLens . _itemProsDeleted %= (trait:)
return (Right (Edit'DeleteTrait itemId traitId traitPos))
return (Right (EditDeleteTrait itemId traitId traitPos))
-- It's a con
(_, Just trait) -> do
mbTraitPos <-
@ -569,7 +569,7 @@ deleteTrait itemId traitId = do
Just traitPos -> do
itemLens . _itemCons %= deleteAt traitPos
itemLens . _itemConsDeleted %= (trait:)
return (Right (Edit'DeleteTrait itemId traitId traitPos))
return (Right (EditDeleteTrait itemId traitId traitPos))
-- other methods
@ -581,7 +581,7 @@ moveItem itemId up = do
let move = if up then moveUp else moveDown
catId <- categoryUid . findCategoryByItem itemId <$> get
categoryById catId . _categoryItems %= move ((== itemId) . itemUid)
return (Edit'MoveItem itemId up)
return (EditMoveItem itemId up)
moveTrait
:: Uid Item
@ -595,7 +595,7 @@ moveTrait itemId traitId up = do
-- a con
itemById itemId . _itemPros %= move ((== traitId) . traitUid)
itemById itemId . _itemCons %= move ((== traitId) . traitUid)
return (Edit'MoveTrait itemId traitId up)
return (EditMoveTrait itemId traitId up)
restoreCategory :: Uid Category -> Int -> Acid.Update GlobalState (Either String ())
restoreCategory catId pos = do

8
back/src/Guide/Types/Analytics.hs
View File

@ -39,10 +39,10 @@ import Guide.Utils
data Action
= Action'MainPageVisit
| Action'CategoryVisit (Uid Category)
| Action'Search Text
| Action'Edit Edit
= ActionMainPageVisit
| ActionCategoryVisit (Uid Category)
| ActionSearch Text
| ActionEdit Edit
deriving (Show)
deriveSafeCopySimple 0 'base ''Action

64
back/src/Guide/Types/Core.hs
View File

@ -41,7 +41,7 @@ import Guide.Markdown
import Guide.Types.Hue
import Guide.Utils
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
import qualified Data.Set as S
import qualified Data.Text as T
@ -73,9 +73,9 @@ makeClassWithLenses ''Trait
changelog ''Trait (Current 4, Past 3) []
deriveSafeCopySorted 3 'base ''Trait_v3
instance A.ToJSON Trait where
toJSON = A.genericToJSON A.defaultOptions {
A.fieldLabelModifier = over _head toLower . drop (T.length "trait") }
instance Aeson.ToJSON Trait where
toJSON = Aeson.genericToJSON Aeson.defaultOptions {
Aeson.fieldLabelModifier = over _head toLower . drop (T.length "trait") }
-- | ADT for trait type. Traits can be pros (positive traits) and cons
-- (negative traits).
@ -100,21 +100,21 @@ hackageName f (Library x) = Library <$> f x
hackageName f (Tool x) = Tool <$> f x
hackageName _ Other = pure Other
instance A.ToJSON ItemKind where
toJSON (Library x) = A.object [
"tag" A..= ("Library" :: Text),
"contents" A..= x ]
toJSON (Tool x) = A.object [
"tag" A..= ("Tool" :: Text),
"contents" A..= x ]
toJSON Other = A.object [
"tag" A..= ("Other" :: Text) ]
instance Aeson.ToJSON ItemKind where
toJSON (Library x) = Aeson.object [
"tag" Aeson..= ("Library" :: Text),
"contents" Aeson..= x ]
toJSON (Tool x) = Aeson.object [
"tag" Aeson..= ("Tool" :: Text),
"contents" Aeson..= x ]
toJSON Other = Aeson.object [
"tag" Aeson..= ("Other" :: Text) ]
instance A.FromJSON ItemKind where
parseJSON = A.withObject "ItemKind" $ \o ->
o A..: "tag" >>= \case
("Library" :: Text) -> Library <$> o A..: "contents"
"Tool" -> Tool <$> o A..: "contents"
instance Aeson.FromJSON ItemKind where
parseJSON = Aeson.withObject "ItemKind" $ \o ->
o Aeson..: "tag" >>= \case
("Library" :: Text) -> Library <$> o Aeson..: "contents"
"Tool" -> Tool <$> o Aeson..: "contents"
"Other" -> pure Other
tag -> fail ("unknown tag " ++ show tag)
@ -142,11 +142,11 @@ data ItemSection
deriveSafeCopySimple 0 'base ''ItemSection
instance A.ToJSON ItemSection where
toJSON = A.genericToJSON A.defaultOptions
instance Aeson.ToJSON ItemSection where
toJSON = Aeson.genericToJSON Aeson.defaultOptions
instance A.FromJSON ItemSection where
parseJSON = A.genericParseJSON A.defaultOptions
instance Aeson.FromJSON ItemSection where
parseJSON = Aeson.genericParseJSON Aeson.defaultOptions
-- TODO: add a field like “people to ask on IRC about this library if you
-- need help”
@ -191,9 +191,9 @@ deriveSafeCopySorted 11 'extension ''Item_v11
changelog ''Item (Past 11, Past 10) []
deriveSafeCopySorted 10 'base ''Item_v10
instance A.ToJSON Item where
toJSON = A.genericToJSON A.defaultOptions {
A.fieldLabelModifier = over _head toLower . drop (T.length "item") }
instance Aeson.ToJSON Item where
toJSON = Aeson.genericToJSON Aeson.defaultOptions {
Aeson.fieldLabelModifier = over _head toLower . drop (T.length "item") }
----------------------------------------------------------------------------
-- Category
@ -208,11 +208,11 @@ data CategoryStatus
deriveSafeCopySimple 2 'extension ''CategoryStatus
instance A.ToJSON CategoryStatus where
toJSON = A.genericToJSON A.defaultOptions
instance Aeson.ToJSON CategoryStatus where
toJSON = Aeson.genericToJSON Aeson.defaultOptions
instance A.FromJSON CategoryStatus where
parseJSON = A.genericParseJSON A.defaultOptions
instance Aeson.FromJSON CategoryStatus where
parseJSON = Aeson.genericParseJSON Aeson.defaultOptions
data CategoryStatus_v1
= CategoryStub_v1
@ -275,9 +275,9 @@ deriveSafeCopySorted 9 'extension ''Category_v9
changelog ''Category (Past 9, Past 8) []
deriveSafeCopySorted 8 'base ''Category_v8
instance A.ToJSON Category where
toJSON = A.genericToJSON A.defaultOptions {
A.fieldLabelModifier = over _head toLower . drop (T.length "category") }
instance Aeson.ToJSON Category where
toJSON = Aeson.genericToJSON Aeson.defaultOptions {
Aeson.fieldLabelModifier = over _head toLower . drop (T.length "category") }
-- | Category identifier (used in URLs). E.g. for a category with title
-- “Performance optimization” and UID “t3c9hwzo” the slug would be

268
back/src/Guide/Types/Edit.hs
View File

@ -31,100 +31,100 @@ import Guide.Utils
-- | Edits made by users. It should always be possible to undo an edit.
data Edit
-- Add
= Edit'AddCategory {
= EditAddCategory {
editCategoryUid :: Uid Category,
editCategoryTitle :: Text,
editCategoryGroup :: Text }
| Edit'AddItem {
| EditAddItem {
editCategoryUid :: Uid Category,
editItemUid :: Uid Item,
editItemName :: Text }
| Edit'AddPro {
| EditAddPro {
editItemUid :: Uid Item,
editTraitId :: Uid Trait,
editTraitContent :: Text }
| Edit'AddCon {
| EditAddCon {
editItemUid :: Uid Item,
editTraitId :: Uid Trait,
editTraitContent :: Text }
-- Change category properties
| Edit'SetCategoryTitle {
| EditSetCategoryTitle {
editCategoryUid :: Uid Category,
editCategoryTitle :: Text,
editCategoryNewTitle :: Text }
| Edit'SetCategoryGroup {
| EditSetCategoryGroup {
editCategoryUid :: Uid Category,
editCategoryGroup :: Text,
editCategoryNewGroup :: Text }
| Edit'SetCategoryNotes {
| EditSetCategoryNotes {
editCategoryUid :: Uid Category,
editCategoryNotes :: Text,
editCategoryNewNotes :: Text }
| Edit'SetCategoryStatus {
| EditSetCategoryStatus {
editCategoryUid :: Uid Category,
editCategoryStatus :: CategoryStatus,
editCategoryNewStatus :: CategoryStatus }
| Edit'ChangeCategoryEnabledSections {
| EditChangeCategoryEnabledSections {
editCategoryUid :: Uid Category,
editCategoryEnableSections :: Set ItemSection,
editCategoryDisableSections :: Set ItemSection }
-- Change item properties
| Edit'SetItemName {
| EditSetItemName {
editItemUid :: Uid Item,
editItemName :: Text,
editItemNewName :: Text }
| Edit'SetItemLink {
| EditSetItemLink {
editItemUid :: Uid Item,
editItemLink :: Maybe Url,
editItemNewLink :: Maybe Url }
| Edit'SetItemGroup { -- TODO: remove after migration to Postgres
| EditSetItemGroup { -- TODO: remove after migration to Postgres
editItemUid :: Uid Item,
editItemGroup :: Maybe Text,
editItemNewGroup :: Maybe Text }
| Edit'SetItemHackage {
| EditSetItemHackage {
editItemUid :: Uid Item,
editItemHackage :: Maybe Text,
editItemNewHackage :: Maybe Text }
| Edit'SetItemSummary {
| EditSetItemSummary {
editItemUid :: Uid Item,
editItemSummary :: Text,
editItemNewSummary :: Text }
| Edit'SetItemNotes {
| EditSetItemNotes {
editItemUid :: Uid Item,
editItemNotes :: Text,
editItemNewNotes :: Text }
| Edit'SetItemEcosystem {
| EditSetItemEcosystem {
editItemUid :: Uid Item,
editItemEcosystem :: Text,
editItemNewEcosystem :: Text }
-- Change trait properties
| Edit'SetTraitContent {
| EditSetTraitContent {
editItemUid :: Uid Item,
editTraitUid :: Uid Trait,
editTraitContent :: Text,
editTraitNewContent :: Text }
-- Delete
| Edit'DeleteCategory {
| EditDeleteCategory {
editCategoryUid :: Uid Category,
editCategoryPosition :: Int }
| Edit'DeleteItem {
| EditDeleteItem {
editItemUid :: Uid Item,
editItemPosition :: Int }
| Edit'DeleteTrait {
| EditDeleteTrait {
editItemUid :: Uid Item,
editTraitUid :: Uid Trait,
editTraitPosition :: Int }
-- Other
| Edit'MoveItem {
| EditMoveItem {
editItemUid :: Uid Item,
editDirection :: Bool }
| Edit'MoveTrait {
| EditMoveTrait {
editItemUid :: Uid Item,
editTraitUid :: Uid Trait,
editDirection :: Bool }
@ -135,36 +135,36 @@ deriveSafeCopySimple 9 'extension ''Edit
genVer ''Edit (Current 9, Past 8) [
-- Add
Copy "Edit'AddCategory",
Copy "Edit'AddItem",
Copy "Edit'AddPro",
Copy "Edit'AddCon",
Copy "EditAddCategory",
Copy "EditAddItem",
Copy "EditAddPro",
Copy "EditAddCon",
-- Change category properties
Copy "Edit'SetCategoryTitle",
Copy "Edit'SetCategoryGroup",
Copy "Edit'SetCategoryNotes",
Copy "Edit'SetCategoryStatus",
Copy "Edit'ChangeCategoryEnabledSections",
Copy "EditSetCategoryTitle",
Copy "EditSetCategoryGroup",
Copy "EditSetCategoryNotes",
Copy "EditSetCategoryStatus",
Copy "EditChangeCategoryEnabledSections",
-- Change item properties
Copy "Edit'SetItemName",
Copy "Edit'SetItemLink",
Copy "Edit'SetItemGroup",
Custom "Edit'SetItemKind" [
Copy "EditSetItemName",
Copy "EditSetItemLink",
Copy "EditSetItemGroup",
Custom "EditSetItemKind" [
("editItemUid", [t|Uid Item|]),
("editItemKind", [t|ItemKind|]),
("editItemNewKind", [t|ItemKind|])],
Copy "Edit'SetItemSummary",
Copy "Edit'SetItemNotes",
Copy "Edit'SetItemEcosystem",
Copy "EditSetItemSummary",
Copy "EditSetItemNotes",
Copy "EditSetItemEcosystem",
-- Change trait properties
Copy "Edit'SetTraitContent",
Copy "EditSetTraitContent",
-- Delete
Copy "Edit'DeleteCategory",
Copy "Edit'DeleteItem",
Copy "Edit'DeleteTrait",
Copy "EditDeleteCategory",
Copy "EditDeleteItem",
Copy "EditDeleteTrait",
-- Other
Copy "Edit'MoveItem",
Copy "Edit'MoveTrait" ]
Copy "EditMoveItem",
Copy "EditMoveTrait" ]
deriveSafeCopySimple 8 'extension ''Edit_v8
@ -172,22 +172,22 @@ instance Migrate Edit where
type MigrateFrom Edit = Edit_v8
migrate = $(migrateVer ''Edit (Current 9, Past 8) [
-- Add
CopyM "Edit'AddCategory",
CopyM "Edit'AddItem",
CopyM "Edit'AddPro",
CopyM "Edit'AddCon",
CopyM "EditAddCategory",
CopyM "EditAddItem",
CopyM "EditAddPro",
CopyM "EditAddCon",
-- Change category properties
CopyM "Edit'SetCategoryTitle",
CopyM "Edit'SetCategoryGroup",
CopyM "Edit'SetCategoryNotes",
CopyM "Edit'SetCategoryStatus",
CopyM "Edit'ChangeCategoryEnabledSections",
CopyM "EditSetCategoryTitle",
CopyM "EditSetCategoryGroup",
CopyM "EditSetCategoryNotes",
CopyM "EditSetCategoryStatus",
CopyM "EditChangeCategoryEnabledSections",
-- Change item properties
CopyM "Edit'SetItemName",
CopyM "Edit'SetItemLink",
CopyM "Edit'SetItemGroup",
CustomM "Edit'SetItemKind" [|\x ->
Edit'SetItemHackage
CopyM "EditSetItemName",
CopyM "EditSetItemLink",
CopyM "EditSetItemGroup",
CustomM "EditSetItemKind" [|\x ->
EditSetItemHackage
{ editItemUid = editItemUid_v8 x
, editItemHackage = case editItemKind_v8 x of
Library m -> m
@ -199,129 +199,129 @@ instance Migrate Edit where
Other -> Nothing
}
|],
CopyM "Edit'SetItemSummary",
CopyM "Edit'SetItemNotes",
CopyM "Edit'SetItemEcosystem",
CopyM "EditSetItemSummary",
CopyM "EditSetItemNotes",
CopyM "EditSetItemEcosystem",
-- Change trait properties
CopyM "Edit'SetTraitContent",
CopyM "EditSetTraitContent",
-- Delete
CopyM "Edit'DeleteCategory",
CopyM "Edit'DeleteItem",
CopyM "Edit'DeleteTrait",
CopyM "EditDeleteCategory",
CopyM "EditDeleteItem",
CopyM "EditDeleteTrait",
-- Other
CopyM "Edit'MoveItem",
CopyM "Edit'MoveTrait"
CopyM "EditMoveItem",
CopyM "EditMoveTrait"
])
genVer ''Edit (Past 8, Past 7) [
-- Add
Custom "Edit'AddCategory" [
Custom "EditAddCategory" [
("editCategoryUid" , [t|Uid Category|]),
("editCategoryTitle", [t|Text|]) ],
Copy "Edit'AddItem",
Copy "Edit'AddPro",
Copy "Edit'AddCon",
Copy "EditAddItem",
Copy "EditAddPro",
Copy "EditAddCon",
-- Change category properties
Copy "Edit'SetCategoryTitle",
Copy "Edit'SetCategoryGroup",
Copy "Edit'SetCategoryNotes",
Copy "Edit'SetCategoryStatus",
Copy "Edit'ChangeCategoryEnabledSections",
Copy "EditSetCategoryTitle",
Copy "EditSetCategoryGroup",
Copy "EditSetCategoryNotes",
Copy "EditSetCategoryStatus",
Copy "EditChangeCategoryEnabledSections",
-- Change item properties
Copy "Edit'SetItemName",
Copy "Edit'SetItemLink",
Copy "Edit'SetItemGroup",
Copy "Edit'SetItemKind",
Copy "Edit'SetItemSummary",
Copy "Edit'SetItemNotes",
Copy "Edit'SetItemEcosystem",
Copy "EditSetItemName",
Copy "EditSetItemLink",
Copy "EditSetItemGroup",
Copy "EditSetItemKind",
Copy "EditSetItemSummary",
Copy "EditSetItemNotes",
Copy "EditSetItemEcosystem",
-- Change trait properties
Copy "Edit'SetTraitContent",
Copy "EditSetTraitContent",
-- Delete
Copy "Edit'DeleteCategory",
Copy "Edit'DeleteItem",
Copy "Edit'DeleteTrait",
Copy "EditDeleteCategory",
Copy "EditDeleteItem",
Copy "EditDeleteTrait",
-- Other
Copy "Edit'MoveItem",
Copy "Edit'MoveTrait" ]
Copy "EditMoveItem",
Copy "EditMoveTrait" ]
deriveSafeCopySimple 7 'base ''Edit_v7
instance Migrate Edit_v8 where
type MigrateFrom Edit_v8 = Edit_v7
migrate = $(migrateVer ''Edit (Past 8, Past 7) [
CustomM "Edit'AddCategory" [|\x ->
Edit'AddCategory_v8
CustomM "EditAddCategory" [|\x ->
EditAddCategory_v8
{ editCategoryUid_v8 = editCategoryUid_v7 x
, editCategoryTitle_v8 = editCategoryTitle_v7 x
, editCategoryGroup_v8 = toText "Miscellaneous"
} |],
CopyM "Edit'AddItem",
CopyM "Edit'AddPro",
CopyM "Edit'AddCon",
CopyM "EditAddItem",
CopyM "EditAddPro",
CopyM "EditAddCon",
-- Change category properties
CopyM "Edit'SetCategoryTitle",
CopyM "Edit'SetCategoryGroup",
CopyM "Edit'SetCategoryNotes",
CopyM "Edit'SetCategoryStatus",
CopyM "Edit'ChangeCategoryEnabledSections",
CopyM "EditSetCategoryTitle",
CopyM "EditSetCategoryGroup",
CopyM "EditSetCategoryNotes",
CopyM "EditSetCategoryStatus",
CopyM "EditChangeCategoryEnabledSections",
-- Change item properties
CopyM "Edit'SetItemName",
CopyM "Edit'SetItemLink",
CopyM "Edit'SetItemGroup",
CopyM "Edit'SetItemKind",
CopyM "Edit'SetItemSummary",
CopyM "Edit'SetItemNotes",
CopyM "Edit'SetItemEcosystem",
CopyM "EditSetItemName",
CopyM "EditSetItemLink",
CopyM "EditSetItemGroup",
CopyM "EditSetItemKind",
CopyM "EditSetItemSummary",
CopyM "EditSetItemNotes",
CopyM "EditSetItemEcosystem",
-- Change trait properties
CopyM "Edit'SetTraitContent",
CopyM "EditSetTraitContent",
-- Delete
CopyM "Edit'DeleteCategory",
CopyM "Edit'DeleteItem",
CopyM "Edit'DeleteTrait",
CopyM "EditDeleteCategory",
CopyM "EditDeleteItem",
CopyM "EditDeleteTrait",
-- Other
CopyM "Edit'MoveItem",
CopyM "Edit'MoveTrait"
CopyM "EditMoveItem",
CopyM "EditMoveTrait"
])
-- | Determine whether the edit doesn't actually change anything and so isn't
-- worth recording in the list of pending edits.
isVacuousEdit :: Edit -> Bool
isVacuousEdit Edit'SetCategoryTitle {..} =
isVacuousEdit EditSetCategoryTitle {..} =
editCategoryTitle == editCategoryNewTitle
isVacuousEdit Edit'SetCategoryGroup {..} =
isVacuousEdit EditSetCategoryGroup {..} =
editCategoryGroup == editCategoryNewGroup
isVacuousEdit Edit'SetCategoryNotes {..} =
isVacuousEdit EditSetCategoryNotes {..} =
editCategoryNotes == editCategoryNewNotes
isVacuousEdit Edit'SetCategoryStatus {..} =
isVacuousEdit EditSetCategoryStatus {..} =
editCategoryStatus == editCategoryNewStatus
isVacuousEdit Edit'ChangeCategoryEnabledSections {..} =
isVacuousEdit EditChangeCategoryEnabledSections {..} =
null editCategoryEnableSections && null editCategoryDisableSections
isVacuousEdit Edit'SetItemName {..} =
isVacuousEdit EditSetItemName {..} =
editItemName == editItemNewName
isVacuousEdit Edit'SetItemLink {..} =
isVacuousEdit EditSetItemLink {..} =
editItemLink == editItemNewLink
isVacuousEdit Edit'SetItemGroup {..} =
isVacuousEdit EditSetItemGroup {..} =
editItemGroup == editItemNewGroup
isVacuousEdit Edit'SetItemHackage {..} =
isVacuousEdit EditSetItemHackage {..} =
editItemHackage == editItemNewHackage
isVacuousEdit Edit'SetItemSummary {..} =
isVacuousEdit EditSetItemSummary {..} =
editItemSummary == editItemNewSummary
isVacuousEdit Edit'SetItemNotes {..} =
isVacuousEdit EditSetItemNotes {..} =
editItemNotes == editItemNewNotes
isVacuousEdit Edit'SetItemEcosystem {..} =
isVacuousEdit EditSetItemEcosystem {..} =
editItemEcosystem == editItemNewEcosystem
isVacuousEdit Edit'SetTraitContent {..} =
isVacuousEdit EditSetTraitContent {..} =
editTraitContent == editTraitNewContent
isVacuousEdit Edit'AddCategory{} = False
isVacuousEdit Edit'AddItem{} = False
isVacuousEdit Edit'AddPro{} = False
isVacuousEdit Edit'AddCon{} = False
isVacuousEdit Edit'DeleteCategory{} = False
isVacuousEdit Edit'DeleteItem{} = False
isVacuousEdit Edit'DeleteTrait{} = False
isVacuousEdit Edit'MoveItem{} = False
isVacuousEdit Edit'MoveTrait{} = False
isVacuousEdit EditAddCategory{} = False
isVacuousEdit EditAddItem{} = False
isVacuousEdit EditAddPro{} = False
isVacuousEdit EditAddCon{} = False
isVacuousEdit EditDeleteCategory{} = False
isVacuousEdit EditDeleteItem{} = False
isVacuousEdit EditDeleteTrait{} = False
isVacuousEdit EditMoveItem{} = False
isVacuousEdit EditMoveTrait{} = False
data EditDetails = EditDetails {
editIP :: Maybe IP,

8
back/src/Guide/Types/Hue.hs
View File

@ -21,7 +21,7 @@ import Imports
import Data.SafeCopy hiding (kind)
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
data Hue = NoHue | Hue Int
@ -29,9 +29,9 @@ data Hue = NoHue | Hue Int
deriveSafeCopySimple 1 'extension ''Hue
instance A.ToJSON Hue where
toJSON NoHue = A.toJSON (0 :: Int)
toJSON (Hue n) = A.toJSON n
instance Aeson.ToJSON Hue where
toJSON NoHue = Aeson.toJSON (0 :: Int)
toJSON (Hue n) = Aeson.toJSON n
data Hue_v0 = NoHue_v0 | Hue_v0 Int

70
back/src/Guide/Utils.hs
View File

@ -97,11 +97,11 @@ import Language.Haskell.TH.Datatype
-- needed for parsing urls
import Network.HTTP.Types (Query, parseQuery)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encode.Pretty as A
import qualified Data.Aeson.Internal as A
import qualified Data.Aeson.Text as A
import qualified Data.Aeson.Types as A
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.Internal as Aeson
import qualified Data.Aeson.Text as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.XML.Types as XML
@ -320,11 +320,11 @@ newtype Uid a = Uid {uidToText :: Text}
instance Show (Uid a) where
show (Uid a) = show a
instance A.ToJSON (Uid a) where
toJSON = A.toJSON . uidToText
instance Aeson.ToJSON (Uid a) where
toJSON = Aeson.toJSON . uidToText
instance A.FromJSON (Uid a) where
parseJSON a = Uid <$> A.parseJSON a
instance Aeson.FromJSON (Uid a) where
parseJSON a = Uid <$> Aeson.parseJSON a
-- This instance is written manually because otherwise it produces a warning:
-- • Redundant constraint: SafeCopy a
@ -391,49 +391,49 @@ uid_ = id_ . uidToText
class AsJson s where
-- | Parse JSON using the default JSON instance.
fromJson :: A.FromJSON a => s -> Either String a
fromJson = fromJsonWith A.parseJSON
fromJson :: Aeson.FromJSON a => s -> Either String a
fromJson = fromJsonWith Aeson.parseJSON
-- | Parse JSON using a custom parser.
fromJsonWith :: (A.Value -> A.Parser a) -> s -> Either String a
fromJsonWith :: (Aeson.Value -> Aeson.Parser a) -> s -> Either String a
fromJsonWith p s = do
v <- fromJson s
case A.iparse p v of
A.IError path err -> Left (A.formatError path err)
A.ISuccess res -> Right res
case Aeson.iparse p v of
Aeson.IError path err -> Left (Aeson.formatError path err)
Aeson.ISuccess res -> Right res
-- | Convert a value to JSON.
toJson :: A.ToJSON a => a -> s
toJson :: Aeson.ToJSON a => a -> s
-- | Convert a value to pretty-printed JSON.
toJsonPretty :: A.ToJSON a => a -> s
toJsonPretty :: Aeson.ToJSON a => a -> s
instance AsJson ByteString where
fromJson = A.eitherDecodeStrict
toJson = toByteString . A.encode
toJsonPretty = toByteString . A.encodePretty
fromJson = Aeson.eitherDecodeStrict
toJson = toByteString . Aeson.encode
toJsonPretty = toByteString . Aeson.encodePretty
instance AsJson LByteString where
fromJson = A.eitherDecode
toJson = A.encode
toJsonPretty = A.encodePretty
fromJson = Aeson.eitherDecode
toJson = Aeson.encode
toJsonPretty = Aeson.encodePretty
instance AsJson Text where
fromJson = A.eitherDecode . toLByteString
toJson = toText . A.encodeToLazyText
toJsonPretty = toText . A.encodePrettyToTextBuilder
fromJson = Aeson.eitherDecode . toLByteString
toJson = toText . Aeson.encodeToLazyText
toJsonPretty = toText . Aeson.encodePrettyToTextBuilder
instance AsJson LText where
fromJson = A.eitherDecode . toLByteString
toJson = A.encodeToLazyText
toJsonPretty = toLText . A.encodePrettyToTextBuilder
fromJson = Aeson.eitherDecode . toLByteString
toJson = Aeson.encodeToLazyText
toJsonPretty = toLText . Aeson.encodePrettyToTextBuilder
instance AsJson A.Value where
fromJsonWith p v = case A.iparse p v of
A.IError path err -> Left (A.formatError path err)
A.ISuccess res -> Right res
toJson = A.toJSON
toJsonPretty = A.toJSON
instance AsJson Aeson.Value where
fromJsonWith p v = case Aeson.iparse p v of
Aeson.IError path err -> Left (Aeson.formatError path err)
Aeson.ISuccess res -> Right res
toJson = Aeson.toJSON
toJsonPretty = Aeson.toJSON
----------------------------------------------------------------------------
-- Lucid

51
back/src/Guide/Views.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
@ -58,7 +57,7 @@ import Guide.Utils
import Guide.Views.Utils
import qualified CMark as MD
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
import qualified Data.Text as T
import qualified Data.Text.IO as T
@ -309,37 +308,37 @@ renderEdit globalState edit = do
case edit of
-- Add
Edit'AddCategory _catId title' group' -> p_ $ do
EditAddCategory _catId title' group' -> p_ $ do
"added category " >> quote (toHtml title')
" to group " >> quote (toHtml group')
Edit'AddItem catId _itemId name' -> p_ $ do
EditAddItem catId _itemId name' -> p_ $ do
"added item " >> printItem _itemId
" (initially called " >> quote (toHtml name') >> ")"
" to category " >> printCategory catId
Edit'AddPro itemId _traitId content' -> do
EditAddPro itemId _traitId content' -> do
p_ $ "added pro to item " >> printItem itemId
pre_ $ code_ $ toHtml content'
Edit'AddCon itemId _traitId content' -> do
EditAddCon itemId _traitId content' -> do
p_ $ "added con to item " >> printItem itemId
pre_ $ code_ $ toHtml content'
-- Change category properties
Edit'SetCategoryTitle _catId oldTitle newTitle -> p_ $ do
EditSetCategoryTitle _catId oldTitle newTitle -> p_ $ do
"changed title of category " >> quote (toHtml oldTitle)
" to " >> quote (toHtml newTitle)
Edit'SetCategoryGroup catId oldGroup newGroup -> p_ $ do
EditSetCategoryGroup catId oldGroup newGroup -> p_ $ do
"changed group of category " >> printCategory catId
" from " >> quote (toHtml oldGroup)
" to " >> quote (toHtml newGroup)
Edit'SetCategoryStatus catId oldStatus newStatus -> p_ $ do
EditSetCategoryStatus catId oldStatus newStatus -> p_ $ do
"changed status of category " >> printCategory catId
" from " >> quote (toHtml (show oldStatus))
" to " >> quote (toHtml (show newStatus))
Edit'SetCategoryNotes catId oldNotes newNotes -> do
EditSetCategoryNotes catId oldNotes newNotes -> do
p_ $ (if T.null oldNotes then "added" else "changed") >>
" notes of category " >> printCategory catId
renderDiff oldNotes newNotes
Edit'ChangeCategoryEnabledSections catId toEnable toDisable -> do
EditChangeCategoryEnabledSections catId toEnable toDisable -> do
let sectName ItemProsConsSection = "pros/cons"
sectName ItemEcosystemSection = "ecosystem"
sectName ItemNotesSection = "notes"
@ -354,58 +353,58 @@ renderEdit globalState edit = do
" for category " >> printCategory catId
-- Change item properties
Edit'SetItemName _itemId oldName newName -> p_ $ do
EditSetItemName _itemId oldName newName -> p_ $ do
"changed name of item " >> quote (toHtml oldName)
" to " >> quote (toHtml newName)
Edit'SetItemLink itemId oldLink newLink -> p_ $ do
EditSetItemLink itemId oldLink newLink -> p_ $ do
"changed link of item " >> printItem itemId
" from " >> code_ (toHtml (show oldLink))
" to " >> code_ (toHtml (show newLink))
Edit'SetItemGroup itemId oldGroup newGroup -> p_ $ do
EditSetItemGroup itemId oldGroup newGroup -> p_ $ do
"changed group of item " >> printItem itemId
" from " >> code_ (toHtml (show oldGroup))
" to " >> code_ (toHtml (show newGroup))
Edit'SetItemHackage itemId oldHackage newHackage -> p_ $ do
EditSetItemHackage itemId oldHackage newHackage -> p_ $ do
"changed Hackage name of item " >> printItem itemId
" from " >> code_ (toHtml (show oldHackage))
" to " >> code_ (toHtml (show newHackage))
Edit'SetItemSummary itemId oldDescr newDescr -> do
EditSetItemSummary itemId oldDescr newDescr -> do
p_ $ (if T.null oldDescr then "added" else "changed") >>
" description of item " >> printItem itemId
renderDiff oldDescr newDescr
Edit'SetItemNotes itemId oldNotes newNotes -> do
EditSetItemNotes itemId oldNotes newNotes -> do
p_ $ (if T.null oldNotes then "added" else "changed") >>
" notes of item " >> printItem itemId
renderDiff oldNotes newNotes
Edit'SetItemEcosystem itemId oldEcosystem newEcosystem -> do
EditSetItemEcosystem itemId oldEcosystem newEcosystem -> do
p_ $ (if T.null oldEcosystem then "added" else "changed") >>
" ecosystem of item " >> printItem itemId
renderDiff oldEcosystem newEcosystem
-- Change trait properties
Edit'SetTraitContent itemId _traitId oldContent newContent -> do
EditSetTraitContent itemId _traitId oldContent newContent -> do
p_ $ (if T.null oldContent then "added" else "changed") >>
" trait of item " >> printItem itemId >>
" from category " >> printCategory (findItem itemId ^. _1 . _categoryUid)
renderDiff oldContent newContent
-- Delete
Edit'DeleteCategory catId _pos -> p_ $ do
EditDeleteCategory catId _pos -> p_ $ do
"deleted category " >> printCategoryWithItems catId
Edit'DeleteItem itemId _pos -> p_ $ do
EditDeleteItem itemId _pos -> p_ $ do
let (category, item) = findItem itemId
"deleted item " >> quote (toHtml (itemName item))
" from category " >> quote (toHtml (categoryTitle category))
Edit'DeleteTrait itemId traitId _pos -> do
EditDeleteTrait itemId traitId _pos -> do
let (_, item, trait) = findTrait itemId traitId
p_ $ "deleted trait from item " >> quote (toHtml (itemName item))
pre_ $ code_ $ toHtml $ traitContent trait
-- Other
Edit'MoveItem itemId direction -> p_ $ do
EditMoveItem itemId direction -> p_ $ do
"moved item " >> printItem itemId
if direction then " up" else " down"
Edit'MoveTrait itemId traitId direction -> do
EditMoveTrait itemId traitId direction -> do
let (_, item, trait) = findTrait itemId traitId
p_ $ "moved trait of item " >> quote (toHtml (itemName item)) >>
if direction then " up" else " down"
@ -583,8 +582,8 @@ wrapPage pageTitle' page = doctypehtml_ $ do
-- | Render the search box.
renderSearch :: (MonadIO m) => Maybe Text -> HtmlT m ()
renderSearch mbSearchQuery =
mustache "search" $ A.object [
"query" A..= mbSearchQuery ]
mustache "search" $ Aeson.object [
"query" Aeson..= mbSearchQuery ]
-- | Render list of categories on the main page (the one with category groups
-- and categories in it).

26
back/src/Guide/Views/Item.hs
View File

@ -37,7 +37,7 @@ import Guide.Types.Core
import Guide.Utils
import Guide.Views.Utils
import qualified Data.Aeson as A
import qualified Data.Aeson as Aeson
import qualified Data.Text.IO as T
import qualified Guide.JS as JS
@ -97,8 +97,8 @@ renderItemForFeed category item = do
-- | Render item's title.
renderItemTitle :: (MonadIO m) => Item -> HtmlT m ()
renderItemTitle item =
mustache "item-title" $ A.object [
"item" A..= item ]
mustache "item-title" $ Aeson.object [
"item" Aeson..= item ]
-- TODO: warn when a library isn't on Hackage but is supposed to be
-- TODO: give a link to oldest available docs when the new docs aren't there
@ -106,16 +106,16 @@ renderItemTitle item =
-- | Render item info.
renderItemInfo :: (MonadIO m) => Category -> Item -> HtmlT m ()
renderItemInfo cat item =
mustache "item-info" $ A.object [
"category" A..= cat,
"item" A..= item,
"link_to_item" A..= mkItemLink cat item,
"hackage" A..= itemHackage item ]
mustache "item-info" $ Aeson.object [
"category" Aeson..= cat,
"item" Aeson..= item,
"link_to_item" Aeson..= mkItemLink cat item,
"hackage" Aeson..= itemHackage item ]
-- | Render item description.
renderItemDescription :: MonadIO m => Item -> HtmlT m ()
renderItemDescription item = mustache "item-description" $
A.object ["item" A..= item ]
Aeson.object ["item" Aeson..= item ]
-- | Render the “ecosystem” section.
renderItemEcosystem :: MonadIO m => Item -> HtmlT m ()
@ -216,10 +216,10 @@ renderItemTraits item = div_ [class_ "item-traits"] $ do
-- | Render a single trait.
renderTrait :: MonadIO m => Uid Item -> Trait -> HtmlT m ()
renderTrait itemUid trait =
mustache "trait" $ A.object [
"item" A..= A.object [
"uid" A..= itemUid ],
"trait" A..= trait ]
mustache "trait" $ Aeson.object [
"item" Aeson..= Aeson.object [
"uid" Aeson..= itemUid ],
"trait" Aeson..= trait ]
-- | Render the “notes” section.
renderItemNotes :: MonadIO m => Category -> Item -> HtmlT m ()

18
back/src/Guide/Views/Utils.hs
View File

@ -89,8 +89,8 @@ import Guide.Utils
import Guide.Views.Utils.Input
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as M
import qualified Data.Semigroup as Semigroup
@ -280,16 +280,16 @@ TODO: warn about how one shouldn't write @foo("{{bar}}")@ in templates,
because a newline in 'bar' directly after the quote will mess things
up. Write @foo({{{%js bar}}})@ instead.
-}
mustache :: MonadIO m => PName -> A.Value -> HtmlT m ()
mustache :: MonadIO m => PName -> Aeson.Value -> HtmlT m ()
mustache f v = do
let functions = M.fromList [
("selectIf", \[x] -> if x == A.Bool True
then return (A.String "selected")
else return A.Null),
("js", \[x] -> return $ A.String (toJson x)),
("selectIf", \[x] -> if x == Aeson.Bool True
then return (Aeson.String "selected")
else return Aeson.Null),
("js", \[x] -> return $ Aeson.String (toJson x)),
("trace", \xs -> do
mapM_ (BS.putStrLn . toJsonPretty) xs
return A.Null) ]
mapM_ (BSLC.putStrLn . toJsonPretty) xs
return Aeson.Null) ]
widgets <- readWidgets
let templates = [(tname, t) | (HTML_ tname, t) <- widgets]
when (null templates) $

4
back/src/Imports.hs
View File

@ -46,6 +46,10 @@ import Fmt as X
-- Call stack
import GHC.Stack as X (HasCallStack)
-- Don't let HLint complain about Data.ByteString being imported as
-- something other than "BS" (and so on for other modules)
{-# ANN module "HLint: ignore Avoid restricted qualification" #-}
-- | Short type for lazy ByteString
type LByteString = BSL.ByteString
-- | Short type for lazy Text

5
back/tests/ApiSpec.hs
View File

@ -9,8 +9,7 @@ module ApiSpec (tests) where
import Imports hiding ((.=))
import Data.Aeson
import qualified Data.ByteString.Char8 as S8
import qualified Data.Yaml as Yaml
import qualified Data.Yaml as Yaml
import Network.HTTP.Simple
import Control.Monad.Catch
import Network.HTTP.Types.Status
@ -299,7 +298,7 @@ runRequest request = do
pure (getResponseStatus response, getResponseBody response)
newtype Path = Path String
newtype Method = Method S8.ByteString
newtype Method = Method ByteString
makeRequest :: MonadThrow m => Path -> Method -> m Request
makeRequest (Path path) (Method method) = do