servant-auth-streaming.hs

#!/usr/bin/env nix-shell
#!nix-shell -i runhaskell -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [servant-server servant-auth-server servant-streaming-server ])"
#!nix-shell -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/299814b385d2c1553f60ada8216d3b0af3d8d3c6.tar.gz

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}


import           Control.Monad.Reader
import           Control.Monad.Trans.Resource              (ResourceT)
import           Data.Aeson
import           Data.ByteString                           as BS
import           Data.Monoid
import           Data.Text
import           Network.Wai
import           Network.Wai.Handler.Warp                  (defaultSettings,
                                                            runSettings,
                                                            setPort)
import           Network.Wai.Handler.Warp                  (Port)
import           Servant
import           Servant.API.ContentTypes
import           Servant.API.Generic
import           Servant.Auth
import           Servant.Auth.Server
import           Servant.Auth.Server.Internal.AddSetCookie (AddSetCookieApi,
                                                            AddSetCookieApiVerb,
                                                            AddSetCookies,
                                                            Nat (..))

import           GHC.TypeLits                              (KnownNat, natVal)
import           Servant.Server
import           Servant.Server.Generic
import           Servant.Streaming.Server
import           Streaming
import           System.IO                                 (stdout)


-- the gist

import           Servant.Streaming                         (StreamResponse)


type instance AddSetCookieApi (StreamResponse method stat ctyps) = AddSetCookieApiVerb (StreamResponse method stat ctyps)
type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a)

instance (KnownNat status, AllMime contentTypes, ReflectMethod method ) => HasServer (Headers hs (StreamResponse method status contentTypes)) ctx where
  type ServerT (Headers hs (StreamResponse method status contentTypes)) m = m (Headers hs (Streaming.Stream (Of BS.ByteString) (ResourceT IO) ()))
  hoistServerWithContext _ _ nt s = nt s

  route Proxy ctx a = route p ctx _
    where
      p :: Proxy (StreamResponse method status contentTypes)
      p = Proxy
--
data Env = Env
  { stuff :: String
  }

type AppM = ReaderT Env IO


newtype UserId  = UserId Int deriving (Eq, Show, Generic, ToJSON, FromJSON)
instance FromJWT UserId
instance ToJWT UserId

type MyAuth = Auth '[Cookie] UserId

data Routes route = Routes
  { rTest :: route :- MyAuth :> "test" :> StreamResponseGet '[JSON]
  } deriving (Generic)

server :: (CookieSettings, JWTSettings) -> Routes (AsServerT (AppM))
server cookieConfig = Routes
  { rTest = undefined
  }

type RoutesType = ToServantApi Routes

routesApi :: Proxy RoutesType
routesApi = Proxy

main :: IO ()
main  = do
  cookieKey <- generateKey
  let jwtCfg = defaultJWTSettings cookieKey
      cookieCfg = defaultCookieSettings
      cfg =  cookieCfg :. jwtCfg :. EmptyContext

      appToHandler :: AppM a -> Handler a
      appToHandler action = liftIO $ runReaderT action Env { stuff = "" }

  print "serving"
  runSettings (setPort 8000 defaultSettings) $
    serveWithContext routesApi cfg $
    hoistServerWithContext routesApi (Proxy :: Proxy '[CookieSettings, JWTSettings]) appToHandler (toServant $ server (cookieCfg, jwtCfg))