{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Shpadoinkle.Router.Server where
#ifndef ghcjs_HOST_OS
import Data.ByteString.Lazy as BS (ByteString, fromStrict,
length)
import Data.Text.Encoding (encodeUtf8)
import GHC.TypeLits (Symbol)
import Network.Wai (responseLBS)
import Network.Wai.Application.Static (StaticSettings (ssLookupFile, ssMaxAge),
defaultWebAppSettings,
staticApp)
import Servant.API
import Servant.Server (HasServer (ServerT), Server,
Tagged (Tagged))
import Servant.Server.StaticFiles (serveDirectoryWith)
import WaiAppStatic.Types (File (..),
LookupResult (LRFile, LRNotFound),
MaxAge (MaxAgeSeconds), Piece,
toPieces)
import Shpadoinkle (Html)
import Shpadoinkle.Backend.Static (renderStatic)
import Shpadoinkle.Router (HasRouter (..), View)
toFile :: Piece -> ByteString -> File
toFile p bs = File
{ fileGetSize = fromIntegral $ BS.length bs
, fileToResponse = \status headers -> responseLBS status headers bs
, fileName = p
, fileGetHash = pure Nothing
, fileGetModified = Nothing
}
defaultSPAServerSettings
:: FilePath
-> IO (Html m a)
-> StaticSettings
defaultSPAServerSettings root mhtml = settings { ssLookupFile = orIndex, ssMaxAge = MaxAgeSeconds 0 }
where
settings = defaultWebAppSettings root
orIndex ps = do
let file ps' = toFile ps' . BS.fromStrict . encodeUtf8 . renderStatic
res <- ssLookupFile settings ps
html <- mhtml
return $ case (res, toPieces ["index.html"]) of
(LRNotFound, Just [ps']) -> LRFile $ file ps' html
(_, Just [ps']) | [ps'] == ps || Prelude.null ps -> LRFile $ file ps' html
_ -> res
class ServeRouter layout route m a where
serveUI
:: FilePath
-> (route -> IO (Html m a))
-> layout :>> route
-> Server layout
instance (ServeRouter x r m a, ServeRouter y r m a)
=> ServeRouter (x :<|> y) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> (x :<|> y) :>> r -> Server (x :<|> y)
serveUI root view (x :<|> y) = serveUI @x root view x :<|> serveUI @y root view y
{-# INLINABLE serveUI #-}
instance ServeRouter sub r m a
=> ServeRouter (Capture sym x :> sub) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> (x -> sub :>> r) -> Server (Capture sym x :> sub)
serveUI root view = (serveUI @sub root view .)
{-# INLINABLE serveUI #-}
instance ServeRouter sub r m a
=> ServeRouter (QueryParam sym x :> sub) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> (Maybe x -> sub :>> r) -> Server (QueryParam sym x :> sub)
serveUI root view = (serveUI @sub root view .)
{-# INLINABLE serveUI #-}
instance ServeRouter sub r m a
=> ServeRouter (QueryParams sym x :> sub) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> ([x] -> sub :>> r) -> Server (QueryParams sym x :> sub)
serveUI root view = (serveUI @sub root view .)
{-# INLINABLE serveUI #-}
instance ServeRouter sub r m a
=> ServeRouter (QueryFlag sym :> sub) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> (Bool -> sub :>> r) -> Server (QueryFlag sym :> sub)
serveUI root view = (serveUI @sub root view .)
{-# INLINABLE serveUI #-}
instance ServeRouter sub r m a
=> ServeRouter ((path :: Symbol) :> sub) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> (path :> sub) :>> r -> Server (path :> sub)
serveUI = serveUI @sub
{-# INLINABLE serveUI #-}
instance ServeRouter Raw r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> Raw :>> r -> Server Raw
serveUI root view = serveDirectoryWith . defaultSPAServerSettings root . view
{-# INLINABLE serveUI #-}
instance ServeRouter (View n b) r m a where
serveUI :: FilePath -> (r -> IO (Html m a)) -> View n b :>> r -> Server (View n b)
serveUI root view = serveDirectoryWithSpa . defaultSPAServerSettings root . view
{-# INLINABLE serveUI #-}
serveDirectoryWithSpa :: StaticSettings -> ServerT (View m a) n
serveDirectoryWithSpa = Tagged . staticApp
#endif