Skip to content

Commit

Permalink
add HasLink instance for UVerb (#1370)
Browse files Browse the repository at this point in the history
  • Loading branch information
intolerable authored Dec 6, 2020
1 parent 08579ca commit a8f584f
Show file tree
Hide file tree
Showing 2 changed files with 13 additions and 0 deletions.
6 changes: 6 additions & 0 deletions servant/src/Servant/Links.hs
Original file line number Diff line number Diff line change
Expand Up @@ -178,6 +178,7 @@ import Servant.API.Stream
import Servant.API.Sub
(type (:>))
import Servant.API.TypeLevel
import Servant.API.UVerb
import Servant.API.Vault
(Vault)
import Servant.API.Verbs
Expand Down Expand Up @@ -576,6 +577,11 @@ instance HasLink (Stream m status fr ct a) where
type MkLink (Stream m status fr ct a) r = r
toLink toA _ = toA

-- UVerb instances
instance HasLink (UVerb m ct a) where
type MkLink (UVerb m ct a) r = r
toLink toA _ = toA

-- AuthProtext instances
instance HasLink sub => HasLink (AuthProtect tag :> sub) where
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
Expand Down
7 changes: 7 additions & 0 deletions servant/test/Servant/LinksSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,9 @@ type TestApi =
-- Fragment
:<|> "say" :> Fragment String :> Get '[JSON] NoContent

-- UVerb
:<|> "uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent]

-- All of the verbs
:<|> "get" :> Get '[JSON] NoContent
:<|> "put" :> Put '[JSON] NoContent
Expand Down Expand Up @@ -73,6 +76,10 @@ spec = describe "Servant.Links" $ do
["roads", "lead", "to", "rome"]
`shouldBeLink` "all/roads/lead/to/rome"

it "generated correct links for UVerbs" $ do
apiLink (Proxy :: Proxy ("uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent]))
`shouldBeLink` "uverb-example"

it "generates correct links for query flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
:> QueryFlag "fast" :> Delete '[JSON] NoContent)
Expand Down

0 comments on commit a8f584f

Please sign in to comment.