{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Servant.Static.TH.Internal.Server where
import Data.Foldable (foldl1)
import Data.List.NonEmpty (NonEmpty((:|)))
import Language.Haskell.TH
(Dec, Exp, Q, appE, clause, conT, funD, mkName, normalB,
runIO, sigD)
import Language.Haskell.TH.Syntax (addDependentFile)
import Servant.API ((:<|>)((:<|>)))
import Servant.Server (ServerT)
import System.FilePath (takeFileName)
import Servant.Static.TH.Internal.FileTree
import Servant.Static.TH.Internal.Mime
combineWithExp :: Q Exp -> Q Exp -> Q Exp -> Q Exp
combineWithExp :: Q Exp -> Q Exp -> Q Exp -> Q Exp
combineWithExp Q Exp
combiningExp = Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
appE Q Exp
combiningExp
combineWithServantOr :: Q Exp -> Q Exp -> Q Exp
combineWithServantOr :: Q Exp -> Q Exp -> Q Exp
combineWithServantOr = Q Exp -> Q Exp -> Q Exp -> Q Exp
combineWithExp [e|(:<|>)|]
combineMultiWithServantOr :: NonEmpty (Q Exp) -> Q Exp
combineMultiWithServantOr :: NonEmpty (Q Exp) -> Q Exp
combineMultiWithServantOr = (Q Exp -> Q Exp -> Q Exp) -> NonEmpty (Q Exp) -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Q Exp -> Q Exp -> Q Exp
combineWithServantOr
fileTreeToServer :: FileTree -> Q Exp
fileTreeToServer :: FileTree -> Q Exp
fileTreeToServer (FileTreeFile FilePath
filePath ByteString
fileContents) = do
FilePath -> Q ()
addDependentFile FilePath
filePath
MimeTypeInfo Q Type
_ Q Type
_ ByteString -> Q Exp
contentToExp <- FilePath -> Q MimeTypeInfo
extensionToMimeTypeInfoEx FilePath
filePath
let fileName :: FilePath
fileName = FilePath -> FilePath
takeFileName FilePath
filePath
case FilePath
fileName of
FilePath
"index.html" ->
Q Exp -> Q Exp -> Q Exp
combineWithServantOr
(ByteString -> Q Exp
contentToExp ByteString
fileContents)
(ByteString -> Q Exp
contentToExp ByteString
fileContents)
FilePath
_ -> ByteString -> Q Exp
contentToExp ByteString
fileContents
fileTreeToServer (FileTreeDir FilePath
_ NonEmpty FileTree
fileTrees) =
NonEmpty (Q Exp) -> Q Exp
combineMultiWithServantOr (NonEmpty (Q Exp) -> Q Exp) -> NonEmpty (Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (FileTree -> Q Exp) -> NonEmpty FileTree -> NonEmpty (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Exp
fileTreeToServer NonEmpty FileTree
fileTrees
createServerExp
:: FilePath
-> Q Exp
createServerExp :: FilePath -> Q Exp
createServerExp FilePath
templateDir = do
NonEmpty FileTree
fileTree <- IO (NonEmpty FileTree) -> Q (NonEmpty FileTree)
forall a. IO a -> Q a
runIO (IO (NonEmpty FileTree) -> Q (NonEmpty FileTree))
-> IO (NonEmpty FileTree) -> Q (NonEmpty FileTree)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (NonEmpty FileTree)
getFileTreeIgnoreEmpty FilePath
templateDir
NonEmpty (Q Exp) -> Q Exp
combineMultiWithServantOr (NonEmpty (Q Exp) -> Q Exp) -> NonEmpty (Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ (FileTree -> Q Exp) -> NonEmpty FileTree -> NonEmpty (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Exp
fileTreeToServer NonEmpty FileTree
fileTree
createServerDec
:: String
-> String
-> FilePath
-> Q [Dec]
createServerDec :: FilePath -> FilePath -> FilePath -> Q [Dec]
createServerDec FilePath
apiName FilePath
serverName FilePath
templateDir =
let funcName :: Name
funcName = FilePath -> Name
mkName FilePath
serverName
sigTypeQ :: Q Type
sigTypeQ =
[t|forall m. Applicative m => ServerT $(conT (mkName apiName)) m|]
signatureQ :: DecQ
signatureQ = Name -> Q Type -> DecQ
sigD Name
funcName Q Type
sigTypeQ
clauses :: [ClauseQ]
clauses = [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB (FilePath -> Q Exp
createServerExp FilePath
templateDir)) []]
funcQ :: DecQ
funcQ = Name -> [ClauseQ] -> DecQ
funD Name
funcName [ClauseQ]
clauses
in [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [DecQ
signatureQ, DecQ
funcQ]