Add URI fragment as a separate combinator (#1324)

servant-client-core/src/Servant/Client/Core/HasClient.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -13,6 +14,10 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
+#define HAS_TYPE_ERROR
+#endif
+
 module Servant.Client.Core.HasClient (
     clientIn,
     HasClient (..),
@@ -63,17 +68,18 @@ import qualified Network.HTTP.Types                       as H
 import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
                  BuildHeadersTo (..), Capture', CaptureAll, Description,
-                 EmptyAPI, FramingRender (..), FramingUnrender (..),
+                 EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
                  FromSourceIO (..), Header', Headers (..), HttpVersion,
                  IsSecure, MimeRender (mimeRender),
-                 MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
+                 MimeUnrender (mimeUnrender), NoContent (NoContent),
-                 QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
+                 NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
-                 ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
+                 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
-                 ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
+                 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
-                 contentType, getHeadersHList, getResponse, toQueryParam,
+                 Verb, WithNamedContext, contentType, getHeadersHList,
-                 toUrlPiece)
+                 getResponse, toQueryParam, toUrlPiece)
 import           Servant.API.ContentTypes
                  (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
+import           Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
 import           Servant.API.UVerb
@@ -745,6 +751,34 @@ instance ( HasClient m api
   hoistClientMonad pm _ f cl = \authreq ->
     hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
 
+-- | Ignore @'Fragment'@ in client functions.
+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
+-- 
+-- Example:
+--
+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: Maybe Text -> ClientM [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy Nothing' for all books
+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
+#ifdef HAS_TYPE_ERROR
+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
+#else
+instance ( HasClient m api
+#endif
+         ) => HasClient m (Fragment a :> api) where
+
+  type Client m (Fragment a :> api) = Client m api
+
+  clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) 
+
+  hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
+
 -- * Basic Authentication
 
 instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

servant-client/test/Servant/ClientTestUtils.hs

@@ -1,18 +1,18 @@
-{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE PolyKinds             #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -27,20 +27,22 @@ import           Control.Concurrent
 import           Control.Monad.Error.Class
                  (throwError)
 import           Data.Aeson
-import qualified Data.ByteString.Lazy as LazyByteString
+import qualified Data.ByteString.Lazy             as LazyByteString
 import           Data.Char
                  (chr, isPrint)
 import           Data.Monoid ()
 import           Data.Proxy
-import           Data.Text (Text)
+import           Data.Text
-import qualified Data.Text as Text
+                 (Text)
-import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import qualified Data.Text                        as Text
+import           Data.Text.Encoding
+                 (decodeUtf8, encodeUtf8)
 import           GHC.Generics
                  (Generic)
-import qualified Network.HTTP.Client                  as C
+import qualified Network.HTTP.Client              as C
-import qualified Network.HTTP.Types                   as HTTP
+import qualified Network.HTTP.Types               as HTTP
 import           Network.Socket
-import qualified Network.Wai                          as Wai
+import qualified Network.Wai                      as Wai
 import           Network.Wai.Handler.Warp
 import           System.IO.Unsafe
                  (unsafePerformIO)
@@ -50,15 +52,14 @@ import           Web.FormUrlEncoded
 
 import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
-                 BasicAuthData (..), Capture, CaptureAll,
+                 BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,
-                 DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
+                 EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers,
-                 Headers, JSON, MimeRender(mimeRender),
+                 JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
-                 MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
+                 NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
-                 Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
+                 QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union,
-                 StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
+                 WithStatus (WithStatus), addHeader)
-                 addHeader)
 import           Servant.Client
-import qualified Servant.Client.Core.Auth    as Auth
+import qualified Servant.Client.Core.Auth         as Auth
 import           Servant.Server
 import           Servant.Server.Experimental.Auth
 import           Servant.Test.ComprehensiveAPI
@@ -109,6 +110,7 @@ type Api =
   :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
   :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
   :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
+  :<|> "fragment" :> Fragment String :> Get '[JSON] Person
   :<|> "rawSuccess" :> Raw
   :<|> "rawSuccessPassHeaders" :> Raw
   :<|> "rawFailure" :> Raw
@@ -141,6 +143,7 @@ getBody         :: Person -> ClientM Person
 getQueryParam   :: Maybe String -> ClientM Person
 getQueryParams  :: [String] -> ClientM [Person]
 getQueryFlag    :: Bool -> ClientM Bool
+getFragment     :: ClientM Person
 getRawSuccess   :: HTTP.Method -> ClientM Response
 getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
 getRawFailure   :: HTTP.Method -> ClientM Response
@@ -163,6 +166,7 @@ getRoot
   :<|> getQueryParam
   :<|> getQueryParams
   :<|> getQueryFlag
+  :<|> getFragment
   :<|> getRawSuccess
   :<|> getRawSuccessPassHeaders
   :<|> getRawFailure
@@ -188,6 +192,7 @@ server = serve api (
                    Nothing -> throwError $ ServerError 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
+  :<|> return alice
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
   :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

servant-client/test/Servant/SuccessSpec.hs

@@ -1,17 +1,17 @@
-{-# LANGUAGE CPP                    #-}
+{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                  #-}
+{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE PolyKinds             #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications       #-}
+{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies           #-}
+{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE UndecidableInstances   #-}
+{-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@@ -34,20 +34,21 @@ import           Data.Maybe
 import           Data.Monoid ()
 import           Data.Text
                  (Text)
-import qualified Network.HTTP.Client                  as C
+import qualified Network.HTTP.Client                as C
-import qualified Network.HTTP.Types                   as HTTP
+import qualified Network.HTTP.Types                 as HTTP
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
 import           Test.HUnit
 import           Test.QuickCheck
 
 import           Servant.API
-                 (NoContent (NoContent), WithStatus(WithStatus), getHeaders)
+                 (NoContent (NoContent), WithStatus (WithStatus), getHeaders)
 import           Servant.Client
-import qualified Servant.Client.Core.Request as Req
+import qualified Servant.Client.Core.Request        as Req
-import           Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
+import           Servant.Client.Internal.HttpClient
-import           Servant.Test.ComprehensiveAPI
+                 (defaultMakeClientRequest)
 import           Servant.ClientTestUtils
+import           Servant.Test.ComprehensiveAPI
 
 -- This declaration simply checks that all instances are in place.
 _ = client comprehensiveAPIWithoutStreaming
@@ -103,6 +104,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
       forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
         left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
 
+    it "Servant.API.Fragment" $ \(_, baseUrl) -> do
+      left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
     it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
       res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
       case res of

servant-docs/golden/comprehensive.md

@@ -182,6 +182,28 @@
 
 ```
 
+## GET /fragment
+
+### Fragment:
+
+- *foo*: Fragment Int
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
 ## GET /get-int
 
 ### Response:

servant-docs/src/Servant/Docs/Internal.hs

@@ -25,8 +25,8 @@ import           Control.Applicative
 import           Control.Arrow
                  (second)
 import           Control.Lens
-                 (makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
+                 (makeLenses, mapped, over, set, traversed, view, (%~), (&),
-                 (<>~), (^.), (|>))
+                 (.~), (<>~), (^.), (|>))
 import qualified Data.ByteString.Char8      as BSC
 import           Data.ByteString.Lazy.Char8
                  (ByteString)
@@ -64,7 +64,7 @@ import           Servant.API
 import           Servant.API.ContentTypes
 import           Servant.API.TypeLevel
 
-import qualified Data.Universe.Helpers as U
+import qualified Data.Universe.Helpers      as U
 
 import qualified Data.HashMap.Strict        as HM
 import qualified Data.Text                  as T
@@ -161,6 +161,20 @@ data DocQueryParam = DocQueryParam
   , _paramKind   :: ParamKind
   } deriving (Eq, Ord, Show)
 
+-- | A type to represent fragment. Holds the name of the fragment and its description.
+--
+-- Write a 'ToFragment' instance for your fragment types.
+data DocFragment = DocFragment
+  { _fragSymbol :: String -- type supplied
+  , _fragDesc   :: String -- user supplied
+  } deriving (Eq, Ord, Show)
+
+-- | There should be at most one 'Fragment' per API endpoint.
+-- So here we are keeping the first occurrence.
+combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment
+Nothing `combineFragment` mdocFragment = mdocFragment
+Just docFragment `combineFragment` _ = Just docFragment
+
 -- | An introductory paragraph for your documentation. You can pass these to
 -- 'docsWithIntros'.
 data DocIntro = DocIntro
@@ -283,6 +297,7 @@ data Action = Action
   , _captures :: [DocCapture]                -- type collected + user supplied info
   , _headers  :: [Text]                      -- type collected
   , _params   :: [DocQueryParam]             -- type collected + user supplied info
+  , _fragment :: Maybe DocFragment           -- type collected + user supplied info
   , _notes    :: [DocNote]                   -- user supplied
   , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
   , _rqtypes  :: [M.MediaType]               -- type collected
@@ -296,8 +311,9 @@ data Action = Action
 -- As such, we invent a non-commutative, left associative operation
 -- 'combineAction' to mush two together taking the response from the very left.
 combineAction :: Action -> Action -> Action
-Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
+Action a c h p f n m ts body resp
-        Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
+  `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' =
+        Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
 
 -- | Default 'Action'. Has no 'captures', no query 'params', expects
 -- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -305,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod
 -- Tweakable with lenses.
 --
 -- >>> defAction
--- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}}
 --
 -- >>> defAction & response.respStatus .~ 201
--- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
+-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}}
 --
 defAction :: Action
 defAction =
@@ -316,6 +332,7 @@ defAction =
          []
          []
          []
+         Nothing
          []
          []
          []
@@ -368,6 +385,7 @@ makeLenses ''API
 makeLenses ''Endpoint
 makeLenses ''DocCapture
 makeLenses ''DocQueryParam
+makeLenses ''DocFragment
 makeLenses ''DocIntro
 makeLenses ''DocNote
 makeLenses ''Response
@@ -587,6 +605,15 @@ class ToCapture c where
 class ToAuthInfo a where
       toAuthInfo :: Proxy a -> DocAuthentication
 
+-- | The class that helps us get documentation for URL fragments.
+--
+-- Example of an instance:
+--
+-- > instance ToFragment (Fragment a) where
+-- >   toFragment _ = DocFragment "fragment" "fragment description"
+class ToFragment t where
+  toFragment :: Proxy t -> DocFragment
+
 -- | Generate documentation in Markdown format for
 --   the given 'API'.
 --
@@ -629,6 +656,7 @@ markdownWith RenderingOptions{..}  api = unlines $
           capturesStr (action ^. captures) ++
           headersStr (action ^. headers) ++
           paramsStr meth (action ^. params) ++
+          fragmentStr (action ^. fragment) ++
           rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++
           responseStr (action ^. response) ++
           []
@@ -730,6 +758,14 @@ markdownWith RenderingOptions{..}  api = unlines $
 
           where values = param ^. paramValues
 
+        fragmentStr :: Maybe DocFragment -> [String]
+        fragmentStr Nothing = []
+        fragmentStr (Just frag) =
+          [ "### Fragment:", ""
+          , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc)
+          , ""
+          ]
+
         rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String]
         rqbodyStr [] [] = []
         rqbodyStr types s =
@@ -959,6 +995,15 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
           paramP = Proxy :: Proxy (QueryFlag sym)
           action' = over params (|> toParam paramP) action
 
+instance (ToFragment (Fragment a), HasDocs api)
+      => HasDocs (Fragment a :> api) where
+
+  docsFor Proxy (endpoint, action) =
+    docsFor subApiP (endpoint, action')
+
+    where subApiP = Proxy :: Proxy api
+          fragmentP = Proxy :: Proxy (Fragment a)
+          action' = set fragment (Just (toFragment fragmentP)) action
 
 instance HasDocs Raw where
   docsFor _proxy (endpoint, action) _ =

servant-docs/test/Servant/DocsSpec.hs

@@ -58,6 +58,8 @@ instance ToCapture (Capture "foo" Int) where
   toCapture _ = DocCapture "foo" "Capture foo Int"
 instance ToCapture (CaptureAll "foo" Int) where
   toCapture _ = DocCapture "foo" "Capture all foo Int"
+instance ToFragment (Fragment Int) where
+  toFragment _ = DocFragment "foo" "Fragment Int"
 
 -- * specs
 

servant-foreign/src/Servant/Foreign/Internal.hs

@@ -84,6 +84,11 @@ captureArg                 _ = error "captureArg called on non capture"
 
 type Path f = [Segment f]
 
+newtype Frag f = Frag { unFragment :: Arg f }
+  deriving (Data, Eq, Show, Typeable)
+
+makePrisms ''Frag
+
 data ArgType
   = Normal
   | Flag
@@ -115,11 +120,12 @@ makePrisms ''HeaderArg
 data Url f = Url
   { _path     :: Path f
   , _queryStr :: [QueryArg f]
+  , _frag     :: Maybe f
   }
   deriving (Data, Eq, Show, Typeable)
 
 defUrl :: Url f
-defUrl = Url [] []
+defUrl = Url [] [] Nothing
 
 makeLenses ''Url
 
@@ -324,6 +330,16 @@ instance
         { _argName = PathSegment str
         , _argType = typeFor lang ftype (Proxy :: Proxy Bool) }
 
+instance
+  (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api)
+  => HasForeign lang ftype (Fragment a :> api) where
+  type Foreign ftype (Fragment a :> api) = Foreign ftype api
+  foreignFor lang Proxy Proxy req =
+    foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
+      req & reqUrl . frag .~ Just argT
+    where
+      argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a))
+
 instance HasForeign lang ftype Raw where
   type Foreign ftype Raw = HTTP.Method -> Req ftype
 

servant-foreign/test/Servant/ForeignSpec.hs

@@ -14,8 +14,8 @@ module Servant.ForeignSpec where
 import           Data.Monoid
                  ((<>))
 import           Data.Proxy
-import           Servant.Test.ComprehensiveAPI
 import           Servant.Foreign
+import           Servant.Test.ComprehensiveAPI
 import           Servant.Types.SourceT
                  (SourceT)
 
@@ -91,6 +91,7 @@ listFromAPISpec = describe "listFromAPI" $ do
       { _reqUrl        = Url
           [ Segment $ Static "test" ]
           [ QueryArg (Arg "flag" "boolX") Flag ]
+          Nothing
       , _reqMethod     = "GET"
       , _reqHeaders    = [HeaderArg $ Arg "header" "maybe listX of stringX"]
       , _reqBody       = Nothing
@@ -103,6 +104,7 @@ listFromAPISpec = describe "listFromAPI" $ do
       { _reqUrl        = Url
           [ Segment $ Static "test" ]
           [ QueryArg (Arg "param" "maybe intX") Normal ]
+          Nothing
       , _reqMethod     = "POST"
       , _reqHeaders    = []
       , _reqBody       = Just "listX of stringX"
@@ -116,6 +118,7 @@ listFromAPISpec = describe "listFromAPI" $ do
           [ Segment $ Static "test" ]
           -- Should this be |intX| or |listX of intX| ?
           [ QueryArg (Arg "params" "listX of intX") List ]
+          Nothing
       , _reqMethod     = "PUT"
       , _reqHeaders    = []
       , _reqBody       = Just "stringX"
@@ -129,6 +132,7 @@ listFromAPISpec = describe "listFromAPI" $ do
           [ Segment $ Static "test"
           , Segment $ Cap (Arg "id" "intX") ]
           []
+          Nothing
       , _reqMethod     = "DELETE"
       , _reqHeaders    = []
       , _reqBody       = Nothing
@@ -142,6 +146,7 @@ listFromAPISpec = describe "listFromAPI" $ do
           [ Segment $ Static "test"
           , Segment $ Cap (Arg "ids" "listX of intX") ]
           []
+          Nothing
       , _reqMethod     = "GET"
       , _reqHeaders    = []
       , _reqBody       = Nothing

servant-server/src/Servant/Server/Internal.hs

@@ -71,17 +71,17 @@ import           Prelude ()
 import           Prelude.Compat
 import           Servant.API
                  ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
-                 CaptureAll, Description, EmptyAPI, FramingRender (..),
+                 CaptureAll, Description, EmptyAPI, Fragment,
-                 FramingUnrender (..), FromSourceIO (..), Header', If,
+                 FramingRender (..), FramingUnrender (..), FromSourceIO (..),
-                 IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
+                 Header', If, IsSecure (..), NoContentVerb, QueryFlag,
-                 ReflectMethod (reflectMethod), RemoteHost, ReqBody',
+                 QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
-                 SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
+                 RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
-                 Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
+                 Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
                  WithNamedContext)
 import           Servant.API.ContentTypes
                  (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
-                 AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
+                 AllMime, MimeRender (..), MimeUnrender (..), NoContent,
-                 NoContent)
+                 canHandleAcceptH)
 import           Servant.API.Modifiers
                  (FoldLenient, FoldRequired, RequestArgument,
                  unfoldRequestArgument)
@@ -89,8 +89,8 @@ import           Servant.API.ResponseHeaders
                  (GetHeaders, Headers, getHeaders, getResponse)
 import qualified Servant.Types.SourceT                      as S
 import           Web.HttpApiData
-                 (FromHttpApiData, parseHeader, parseQueryParam,
+                 (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
-                 parseUrlPieces, parseUrlPiece)
+                 parseUrlPieces)
 
 import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Context
@@ -106,6 +106,8 @@ import           Servant.Server.Internal.ServerError
 #ifdef HAS_TYPE_ERROR
 import           GHC.TypeLits
                  (ErrorMessage (..), TypeError)
+import           Servant.API.TypeLevel
+                 (AtLeastOneFragment, FragmentUnique)
 #endif
 
 class HasServer api context where
@@ -880,5 +882,28 @@ type HasServerArrowTypeError a b =
     ':$$: 'ShowType b
 #endif
 
+-- | Ignore @'Fragment'@ in server handlers.
+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
+-- >
+-- > server :: Server MyApi
+-- > server = getBooksBy
+-- >   where getBooksBy :: Handler [Book]
+-- >         getBooksBy = ...return all books...
+#ifdef HAS_TYPE_ERROR
+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
+#else
+instance (HasServer api context)
+#endif
+    => HasServer (Fragment a1 :> api) context where
+  type ServerT (Fragment a1 :> api) m = ServerT api m
+
+  route _ = route (Proxy :: Proxy api)
+
+  hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
+
 -- $setup
 -- >>> import Servant

servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

@@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where
 import           Prelude ()
 import           Prelude.Compat
 
-import           Control.Exception                          hiding
+import           Control.Exception            hiding
                  (Handler)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Resource
@@ -28,7 +28,7 @@ import           Test.Hspec
 import           Test.Hspec.Wai
                  (request, shouldRespondWith, with)
 
-import qualified Data.Text                                  as T
+import qualified Data.Text                    as T
 
 import           System.IO.Unsafe
                  (unsafePerformIO)

servant-server/test/Servant/ServerSpec.hs

@@ -1,12 +1,12 @@
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE PolyKinds           #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeOperators       #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 
 module Servant.ServerSpec where
@@ -48,12 +48,12 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
+                 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
-                 HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
+                 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
-                 NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
+                 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
-                 Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
+                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
-                 ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
+                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
-                 UVerb, Verb, addHeader)
+                 UVerb, Union, Verb, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
                  emptyServer, err401, err403, err404, respond, serve,
@@ -92,6 +92,7 @@ spec = do
   captureSpec
   captureAllSpec
   queryParamSpec
+  fragmentSpec
   reqBodySpec
   headerSpec
   rawSpec
@@ -461,6 +462,37 @@ queryParamSpec = do
               { name = "Alice"
               }
 
+-- }}}
+------------------------------------------------------------------------------
+-- * fragmentSpec {{{
+------------------------------------------------------------------------------
+
+type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person
+              :<|> "age"  :> Fragment Integer :> Get '[JSON] Person
+
+fragmentApi :: Proxy FragmentApi
+fragmentApi = Proxy
+
+fragServer :: Server FragmentApi
+fragServer = fragmentServer :<|> fragAge
+  where
+    fragmentServer = return alice
+    fragAge = return alice
+
+fragmentSpec :: Spec
+fragmentSpec = do
+  let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
+        { rawQueryString = params
+        , queryString    = parseQuery params
+        , pathInfo       = pinfo
+        }
+
+  describe "Servant.API.Fragment" $ do
+    it "ignores fragment even if it is present in query" $ do
+      flip runSession (serve fragmentApi fragServer) $ do
+        response1 <- mkRequest "#Alice" ["name"]
+        liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * reqBodySpec {{{

servant/servant.cabal

@@ -40,6 +40,7 @@ library
     Servant.API.Description
     Servant.API.Empty
     Servant.API.Experimental.Auth
+    Servant.API.Fragment
     Servant.API.Generic
     Servant.API.Header
     Servant.API.HttpVersion

servant/src/Servant/API.hs

@@ -19,6 +19,8 @@ module Servant.API (
   -- | Retrieving the HTTP version of the request
   module Servant.API.QueryParam,
   -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@
+  module Servant.API.Fragment,
+  -- | Documenting the fragment of the 'URI': @'Fragment'@
   module Servant.API.ReqBody,
   -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@
   module Servant.API.RemoteHost,
@@ -93,6 +95,8 @@ import           Servant.API.Empty
                  (EmptyAPI (..))
 import           Servant.API.Experimental.Auth
                  (AuthProtect)
+import           Servant.API.Fragment
+                 (Fragment)
 import           Servant.API.Header
                  (Header, Header')
 import           Servant.API.HttpVersion
@@ -121,21 +125,20 @@ import           Servant.API.Stream
                  ToSourceIO (..))
 import           Servant.API.Sub
                  ((:>))
+import           Servant.API.UVerb
+                 (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union,
+                 Unique, WithStatus (..), inject, statusOf)
 import           Servant.API.Vault
                  (Vault)
 import           Servant.API.Verbs
                  (Delete, DeleteAccepted, DeleteNoContent,
                  DeleteNonAuthoritative, Get, GetAccepted, GetNoContent,
                  GetNonAuthoritative, GetPartialContent, GetResetContent,
-                 Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative,
+                 NoContentVerb, Patch, PatchAccepted, PatchNoContent,
-                 Post, PostAccepted, PostCreated, PostNoContent,
+                 PatchNonAuthoritative, Post, PostAccepted, PostCreated,
-                 PostNonAuthoritative, PostResetContent, Put, PutAccepted,
+                 PostNoContent, PostNonAuthoritative, PostResetContent, Put,
-                 PutCreated, PutNoContent, PutNonAuthoritative,
+                 PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative,
-                 ReflectMethod (reflectMethod), StdMethod (..),
+                 ReflectMethod (reflectMethod), StdMethod (..), Verb)
-                 Verb, NoContentVerb)
-import           Servant.API.UVerb
-                 (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,
-                 WithStatus (..), IsMember, Unique, inject)
 import           Servant.API.WithNamedContext
                  (WithNamedContext)
 import           Servant.Links

servant/src/Servant/API/Fragment.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# OPTIONS_HADDOCK not-home    #-}
+module Servant.API.Fragment (Fragment) where
+
+import           Data.Typeable
+                 (Typeable)
+
+-- | Document the URI fragment in API. Useful in combination with 'Link'.
+--
+-- Example:
+--
+-- >>> -- /post#TRACKING
+-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking
+data Fragment (a :: *)
+    deriving Typeable
+
+-- $setup
+-- >>> import Servant.API
+-- >>> import Data.Aeson
+-- >>> import Data.Text
+-- >>> data Tracking
+-- >>> instance ToJSON Tracking where { toJSON = undefined }

servant/src/Servant/API/Modifiers.hs

@@ -131,8 +131,6 @@ type RequestArgument mods a =
        (If (FoldLenient mods) (Either Text a) a)
        (Maybe (If (FoldLenient mods) (Either Text a) a))
 
-
-
 -- | Unfold a value into a 'RequestArgument'.
 unfoldRequestArgument
     :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods))

servant/src/Servant/API/TypeLevel.hs

@@ -1,12 +1,16 @@
-{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE CPP                      #-}
-{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE ConstraintKinds          #-}
-{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DataKinds                #-}
-{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE FlexibleInstances        #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE KindSignatures           #-}
-{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE MultiParamTypeClasses    #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE PolyKinds                #-}
-{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE UndecidableSuperClasses  #-}
 
 {-|
 This module collects utilities for manipulating @servant@ API types. The
@@ -41,6 +45,9 @@ module Servant.API.TypeLevel (
     -- ** Logic
     Or,
     And,
+    -- ** Fragment
+    FragmentUnique,
+    AtLeastOneFragment
     ) where
 
 
@@ -50,6 +57,7 @@ import           Servant.API.Alternative
                  (type (:<|>))
 import           Servant.API.Capture
                  (Capture, CaptureAll)
+import           Servant.API.Fragment
 import           Servant.API.Header
                  (Header)
 import           Servant.API.QueryParam
@@ -60,6 +68,8 @@ import           Servant.API.Sub
                  (type (:>))
 import           Servant.API.Verbs
                  (Verb)
+import           Servant.API.UVerb
+                 (UVerb)
 import           GHC.TypeLits
                  (ErrorMessage (..), TypeError)
 
@@ -128,6 +138,7 @@ type family IsElem endpoint api :: Constraint where
   IsElem sa (QueryParam x y :> sb)        = IsElem sa sb
   IsElem sa (QueryParams x y :> sb)       = IsElem sa sb
   IsElem sa (QueryFlag x :> sb)           = IsElem sa sb
+  IsElem sa (Fragment x :> sb)            = IsElem sa sb
   IsElem (Verb m s ct typ) (Verb m s ct' typ)
                                           = IsSubList ct ct'
   IsElem e e                              = ()
@@ -241,6 +252,43 @@ We might try to factor these our more cleanly, but the type synonyms and type
 families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
 -}
 
+-- ** Fragment
+
+class FragmentUnique api => AtLeastOneFragment api
+
+-- | If fragment appeared in API endpoint twice, compile-time error would be raised.
+--
+-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
+-- >>> instance AtLeastOneFragment FailAPI
+-- ...
+-- ...Only one Fragment allowed per endpoint in api...
+-- ...
+-- ...In the instance declaration for...
+instance AtLeastOneFragment (Verb m s ct typ)
+
+instance AtLeastOneFragment (UVerb m cts as)
+
+instance AtLeastOneFragment (Fragment a)
+
+type family FragmentUnique api :: Constraint where
+  FragmentUnique (sa :<|> sb)       = And (FragmentUnique sa) (FragmentUnique sb)
+  FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa)
+  FragmentUnique (x :> sa)          = FragmentUnique sa
+  FragmentUnique (Fragment a)       = ()
+  FragmentUnique x                  = ()
+
+type family FragmentNotIn api orig :: Constraint where
+  FragmentNotIn (sa :<|> sb)       orig =
+    And (FragmentNotIn sa orig) (FragmentNotIn sb orig)
+  FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig)
+  FragmentNotIn (x :> sa)          orig = FragmentNotIn sa orig
+  FragmentNotIn (Fragment c)       orig = TypeError (NotUniqueFragmentInApi orig)
+  FragmentNotIn x                  orig = ()
+
+type NotUniqueFragmentInApi api =
+    'Text "Only one Fragment allowed per endpoint in api ‘"
+    ':<>: 'ShowType api
+    ':<>: 'Text "’."
 
 -- $setup
 --
@@ -248,6 +296,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
 --
 -- >>> :set -XPolyKinds
 -- >>> :set -XGADTs
+-- >>> :set -XTypeSynonymInstances -XFlexibleInstances
 -- >>> import Data.Proxy
 -- >>> import Data.Type.Equality
 -- >>> import Servant.API
@@ -255,4 +304,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
 -- >>> instance Show (OK ctx) where show _ = "OK"
 -- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK
 -- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool
+-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent
 -- >>> let sampleAPI = Proxy :: Proxy SampleAPI

servant/src/Servant/Links.hs

@@ -120,6 +120,7 @@ module Servant.Links (
   , Param (..)
   , linkSegments
   , linkQueryParams
+  , linkFragment
 ) where
 
 import           Data.List
@@ -152,6 +153,8 @@ import           Servant.API.Empty
                  (EmptyAPI (..))
 import           Servant.API.Experimental.Auth
                  (AuthProtect)
+import           Servant.API.Fragment
+                 (Fragment)
 import           Servant.API.Generic
 import           Servant.API.Header
                  (Header')
@@ -188,10 +191,13 @@ import           Web.HttpApiData
 data Link = Link
   { _segments    :: [Escaped]
   , _queryParams :: [Param]
+  , _fragment    :: Fragment'
   } deriving Show
 
 newtype Escaped = Escaped String
 
+type Fragment' = Maybe String
+
 escaped :: String -> Escaped
 escaped = Escaped . escapeURIString isUnreserved
 
@@ -208,11 +214,14 @@ linkSegments = map getEscaped . _segments
 linkQueryParams :: Link -> [Param]
 linkQueryParams = _queryParams
 
+linkFragment :: Link -> Fragment'
+linkFragment = _fragment
+
 instance ToHttpApiData Link where
     toHeader   = TE.encodeUtf8 . toUrlPiece
     toUrlPiece l =
         let uri = linkURI l
-        in Text.pack $ uriPath uri ++ uriQuery uri
+        in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
 
 -- | Query parameter.
 data Param
@@ -228,6 +237,9 @@ addQueryParam :: Param -> Link -> Link
 addQueryParam qp l =
     l { _queryParams = _queryParams l <> [qp] }
 
+addFragment :: Fragment' -> Link -> Link
+addFragment fr l = l { _fragment = fr }
+
 -- | Transform 'Link' into 'URI'.
 --
 -- >>> type API = "something" :> Get '[JSON] Int
@@ -245,7 +257,7 @@ addQueryParam qp l =
 -- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
 -- >>> let someRoute = Proxy :: Proxy SomeRoute
 -- >>> safeLink someRoute someRoute "test@example.com"
--- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
 --
 -- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
 -- abc/test%40example.com
@@ -269,11 +281,12 @@ data LinkArrayElementStyle
 -- sum?x=1&x=2&x=3
 --
 linkURI' :: LinkArrayElementStyle -> Link -> URI
-linkURI' addBrackets (Link segments q_params) =
+linkURI' addBrackets (Link segments q_params mfragment) =
     URI mempty  -- No scheme (relative)
         Nothing -- Or authority (relative)
         (intercalate "/" $ map getEscaped segments)
-        (makeQueries q_params) mempty
+        (makeQueries q_params)
+        (makeFragment mfragment)
   where
     makeQueries :: [Param] -> String
     makeQueries [] = ""
@@ -285,6 +298,10 @@ linkURI' addBrackets (Link segments q_params) =
     makeQuery (SingleParam k v)    = escape k <> "=" <> escape (Text.unpack v)
     makeQuery (FlagParam k)        = escape k
 
+    makeFragment :: Fragment' -> String
+    makeFragment Nothing = ""
+    makeFragment (Just fr) = "#" <> escape fr
+
     style = case addBrackets of
         LinkArrayElementBracket -> "[]="
         LinkArrayElementPlain -> "="
@@ -310,7 +327,7 @@ safeLink'
     -> Proxy api      -- ^ The whole API that this endpoint is a part of
     -> Proxy endpoint -- ^ The API endpoint you would like to point to
     -> MkLink endpoint a
-safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
 
 -- | Create all links in an API.
 --
@@ -341,7 +358,7 @@ allLinks'
     => (Link -> a)
     -> Proxy api
     -> MkLink api a
-allLinks' toA api = toLink toA api (Link mempty mempty)
+allLinks' toA api = toLink toA api (Link mempty mempty mempty)
 
 -------------------------------------------------------------------------------
 -- Generics
@@ -563,6 +580,13 @@ instance HasLink sub => HasLink (AuthProtect tag :> sub) where
   type MkLink (AuthProtect tag :> sub) a = MkLink sub a
   toLink = simpleToLink (Proxy :: Proxy sub)
 
+instance (HasLink sub, ToHttpApiData v)
+    => HasLink (Fragment v :> sub) where
+  type MkLink (Fragment v :> sub) a = v -> MkLink sub a
+  toLink toA _ l mv =
+      toLink toA (Proxy :: Proxy sub) $
+         addFragment ((Just . Text.unpack . toQueryParam) mv) l
+
 -- | Helper for implementing 'toLink' for combinators not affecting link
 -- structure.
 simpleToLink

servant/src/Servant/Test/ComprehensiveAPI.hs

@@ -71,6 +71,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
     :<|> "summary"          :> Summary "foo" :> GET
     :<|> "description"      :> Description "foo" :> GET
     :<|> "alternative"      :> ("left" :> GET :<|> "right" :> GET)
+    :<|> "fragment"         :> Fragment Int :> GET
     :<|> endpoint
 
 type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint

servant/test/Servant/LinksSpec.hs

@@ -13,9 +13,9 @@ import           Test.Hspec
                  (Expectation, Spec, describe, it, shouldBe)
 
 import           Servant.API
+import           Servant.Links
 import           Servant.Test.ComprehensiveAPI
                  (comprehensiveAPIWithoutRaw)
-import           Servant.Links
 
 type TestApi =
   -- Capture and query params
@@ -26,6 +26,9 @@ type TestApi =
   -- Flags
   :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent
 
+  -- Fragment
+  :<|> "say" :> Fragment String :> Get '[JSON] NoContent
+
   -- All of the verbs
   :<|> "get" :> Get '[JSON] NoContent
   :<|> "put" :> Put '[JSON] NoContent
@@ -76,6 +79,10 @@ spec = describe "Servant.Links" $ do
         apiLink l1 True True `shouldBeLink` "balls?bouncy&fast"
         apiLink l1 False True `shouldBeLink` "balls?fast"
 
+    it "generates correct link for fragment" $ do
+        let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent)
+        apiLink l1 "something" `shouldBeLink` "say#something"
+
     it "generates correct links for all of the verbs" $ do
         apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get"
         apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put"