How we do servant versions at Anchor

Versions.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- | Description: API version in Servant requests.
module Servant.Anchor.Version where

import Control.Lens.Operators
import Data.Maybe
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import GHC.TypeLits
import Network.Wai
import Servant.API
import Servant.Client
import Servant.Common.Req
import Servant.Docs hiding (method)
import Servant.Server
import Text.Read

import Servant.Anchor.Fail
import Servant.Ekg

-- | Request must specify version compatible with @major.minor.patch@
data Version (major :: Nat) (minor :: Nat) (patch :: Nat)

-- | Check request has compatible API version.
instance (KnownNat major, KnownNat minor, KnownNat patch, HasServer sub) =>
         HasServer (Version major minor patch :> sub)
  where
    type ServerT (Version major minor patch :> sub) m
        = ServerT sub m

    route Proxy subserver request respond = case pathInfo request of
        (first : rest) -> do
            let match = parseVersionNumber first >>= matchVersion version
            case match of
                Nothing -> respond $
                    failWith (400, "Bad Request") "Incompatible version"
                Just _ ->
                    route (Proxy :: Proxy sub) subserver request{
                        pathInfo = rest
                    } respond
        [] -> respond $ failWith (400, "Bad Request") "Version required"
      where
        nat :: forall n. (KnownNat n) => Proxy n -> Int
        nat = fromInteger . natVal
        version = (nat major, nat minor, nat patch)
        major = Proxy :: Proxy major
        minor = Proxy :: Proxy minor
        patch = Proxy :: Proxy patch
        matchVersion :: (Int, Int, Int) -> (Int, Int, Int) -> Maybe (Int, Int, Int)
        matchVersion (sma, smi, _spa) (cma, cmi, cpa) =
            if sma == cma && cmi >= smi
                then Just (cma, cmi, cpa)
                else Nothing

instance (KnownNat a, KnownNat b, KnownNat c, HasClient sublayout) => HasClient (Version a b c :> sublayout) where

    type Client (Version a b c :> sublayout)
        = Client sublayout

    clientWithRoute Proxy req =
        clientWithRoute (Proxy :: Proxy sublayout) $
           appendToPath (T.unpack $ formatVersion (Proxy :: Proxy (Version a b c))) req

-- | Prepend version to endpoint paths
instance (KnownNat ma, KnownNat mi, KnownNat pa, HasDocs sublayout)
            => HasDocs (Version ma mi pa :> sublayout) where
    docsFor Proxy (endpoint,action) =
        docsFor sub (endpoint & path %~ (version Proxy <|), action)
      where
        version :: Proxy (Version ma mi pa) -> String
        version = T.unpack . formatVersion

        sub :: Proxy sublayout
        sub = Proxy

instance (KnownNat ma, KnownNat mi, KnownNat pa, HasEndpoint (sub :: *)) => HasEndpoint (Version ma mi pa :> sub) where
    getEndpoint _ req =
        case pathInfo req of
            p:ps | p == formatVersion (Proxy :: Proxy (Version ma mi pa))-> do
                (end, method) <- getEndpoint (Proxy :: Proxy sub) req{ pathInfo = ps }
                return ((T.replace "." "_" p):end, method)
            _ -> Nothing

-- | Format a 'Version' as a Text.
formatVersion
    :: forall ma mi pa. (KnownNat ma, KnownNat mi, KnownNat pa)
    => Proxy (Version ma mi pa)
    -> Text
formatVersion Proxy = "v" <> major <> "." <> minor <> "." <> patch
  where
    number :: (KnownNat n) => Proxy n -> Text
    number = T.pack . show . natVal
    major = number (Proxy :: Proxy ma)
    minor = number (Proxy :: Proxy mi)
    patch = number (Proxy :: Proxy pa)

-- | Parse a 'Text' string of a 'Version' into the corresponding numbers.
parseVersionNumber
    :: Text
    -> Maybe (Int, Int, Int)
parseVersionNumber t =
    case T.uncons t of
        Just ('v', rest) ->
            case mapMaybe (readMaybe . T.unpack) $ T.splitOn "." rest of
                [ma,mi,pa] -> Just (ma, mi, pa)
                _ -> Nothing
        _ -> Nothing