Solga - servant but better

solga.hs

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

module Solga where

import           Control.Applicative
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Char8 as Char8
import           Data.Proxy
import qualified Data.Text as Text
import           Data.Text (Text)
import           GHC.TypeLits
import qualified Network.Wai as Wai
import qualified Network.HTTP.Types as HTTP

import System.Random (getStdRandom, random)

-- Solga: simpler typesafe routing

-- API specification. This is a regular inhabited type!
type Example
  =    "simple" /> Method "GET" :> JSON Int
  :<|> "echo" /> Capture :> Method "GET" :> JSON Text
  :<|> "concat" /> Capture :> Capture :> Method "GET" :> JSON Text
  :<|> "rng" /> Get Int

-- API implementation, briefly.
exampleBrief :: Example
exampleBrief = brief $
         3
    :<|> id
    :<|> Text.append
    :<|> getStdRandom random

-- API implementation, written out.
example :: Example
example
  =      (Dir $ Method $ JSON 3)
    :<|> (Dir $ Capture $ \foo -> Method $ JSON foo)
    :<|> (Dir $ Capture $ \str1 -> Capture $ \str2 -> Method $ JSON $ Text.append str1 str2)
    :<|> (Dir $ Method $ WithIO $ fmap JSON $ getStdRandom random)

---------------------------------------------------

type Segment = Text

type Path = [ Segment ]

data RoutedRequest = RoutedRequest
  { routedRequest :: Wai.Request
  , routedPath :: Path
  }

-- The right hand side of Application. Request is already known.
type Responder = (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived

class Router r where
-- | Given a request, if the router supports the given request
-- return a function that constructs a response with a concrete router.
  tryRoute :: RoutedRequest -> Maybe (r -> Responder)

serve :: Router r => r -> Wai.Application
serve router req cont
  = case tryRoute rreq of
      Nothing -> cont $ Wai.responseLBS HTTP.status404 [] "not found"
      Just r -> r router cont
    where
      rreq = RoutedRequest
        { routedRequest = req
        , routedPath = Wai.pathInfo req
        }

-- Router composition is just functor composition.
type f :> g = f g
infixr 2 :>

-- For sanity (see later)
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap

-- | Serve a given WAI Application.
newtype Raw = Raw Wai.Application

instance Router Raw where
  tryRoute rreq = Just $ \(Raw app) -> app (routedRequest rreq)

-- | Match a constant directory in the path.
newtype Dir (seg :: Symbol) next = Dir next

type seg /> g = Dir seg :> g
infixr 2 />

instance (KnownSymbol seg, Router next) => Router (seg /> next) where
  tryRoute rreq = case routedPath rreq of
    s : segs | Text.unpack s == symbolVal (Proxy :: Proxy seg)
      -> tryRoute rreq { routedPath = segs } <&> \nextRouter (Dir next) -> nextRouter next
    _ -> Nothing

-- | Try to route with left, or try to route with right.
data left :<|> right
  = left :<|> right

infixr 1 :<|>

instance (Router left, Router right) => Router (left :<|> right) where
  tryRoute rreq
    = routeLeft <|> routeRight
      where
        routeLeft = tryRoute rreq <&> \leftRouter (left :<|> _) -> leftRouter left
        routeRight = tryRoute rreq <&> \rightRouter (_ :<|> right) -> rightRouter right

-- Capture a path segment and pass it on.
newtype Capture next = Capture (Segment -> next)

instance Router next => Router (Capture next) where
  tryRoute rreq = case routedPath rreq of
    [] -> Nothing
    seg : segs
      -> tryRoute rreq { routedPath = segs }
            <&> \nextRouter (Capture f) -> nextRouter (f seg)

-- Accepts requests with a certain method.
newtype Method (method :: Symbol) next = Method next

instance (KnownSymbol method, Router next) => Router (Method method next) where
  tryRoute rreq
    | Char8.unpack (Wai.requestMethod $ routedRequest rreq) == symbolVal (Proxy :: Proxy method)
      = tryRoute rreq <&> \nextRouter (Method next) -> nextRouter next
    | otherwise = Nothing

-- Return a JSON object
newtype JSON a = JSON a

instance Aeson.ToJSON a => Router (JSON a) where
  tryRoute _ = Just $ \(JSON obj) cont ->
    cont $ Wai.responseBuilder HTTP.status200 [] $ Aeson.fromEncoding $ Aeson.toEncoding obj

-- Parse a JSON request body
newtype ReqBody a next = ReqBody (a -> next)

instance (Aeson.FromJSON a, Router next) => Router (ReqBody a next) where
  tryRoute rreq
    = tryRoute rreq <&>
        \nextRouter (ReqBody f) cont -> do
          reqBody <- Wai.requestBody (routedRequest rreq)
          case Aeson.decodeStrict reqBody of
            Nothing -> cont $ Wai.responseLBS HTTP.status400 [] "bad request"
            Just val -> nextRouter (f val) cont

newtype WithIO next = WithIO (IO next)

instance Router next => Router (WithIO next) where
  tryRoute rreq
    = tryRoute rreq <&>
        \nextRouter (WithIO ioNext) cont -> do
          next <- ioNext
          nextRouter next cont

-- Servant compatibility
type Get a = Method "GET" :> WithIO :> JSON a
type Post a = Method "POST" :> WithIO :> JSON a

-- Servant-style abbreviation

class Abbreviated a where
  type Brief a :: *
  brief :: Brief a -> a

instance Abbreviated Raw where
  type Brief Raw = Wai.Application
  brief = Raw

instance Abbreviated next => Abbreviated (Dir seg next) where
  type Brief (Dir seg next) = Brief next
  brief = Dir . brief

instance (Abbreviated left, Abbreviated right) => Abbreviated (left :<|> right) where
  type Brief (left :<|> right) = Brief left :<|> Brief right
  brief (l :<|> r) = brief l :<|> brief r

instance Abbreviated next => Abbreviated (Capture next) where
  type Brief (Capture next) = Segment -> Brief next
  brief f = Capture (brief . f)

instance Abbreviated next => Abbreviated (Method method next) where
  type Brief (Method method next) = Brief next
  brief = Method . brief

instance Abbreviated (JSON a) where
  type Brief (JSON a) = a
  brief = JSON

instance Abbreviated next => Abbreviated (ReqBody a next) where
  type Brief (ReqBody a next) = a -> Brief next
  brief f = ReqBody (brief . f)

instance Abbreviated next => Abbreviated (WithIO next) where
  type Brief (WithIO next) = IO (Brief next)
  brief = WithIO . fmap brief