{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Servant.Static.TH.Internal.Server where

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 (Type, 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m 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 a. (a -> a -> a) -> NonEmpty a -> a
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
        -- content to serve on the root
        (ByteString -> Q Exp
contentToExp ByteString
fileContents)
        -- content to serve on the path "index.html"
        (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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Exp
fileTreeToServer NonEmpty FileTree
fileTrees

-- | Take a template directory argument as a 'FilePath' and create a 'ServerT'
-- function that serves the files under the directory.  Empty directories will
-- be ignored. 'index.html' files will also be served at the root.
--
-- Note that the file contents will be embedded in the function.  They will
-- not be served dynamically at runtime.  This makes it easy to create a
-- Haskell binary for a website with all static files completely baked-in.
--
-- For example, assume the following directory structure and file contents:
--
-- @
--   $ tree dir\/
--   dir\/
--   ├── js
--   │   └── test.js
--   └── index.html
-- @
--
-- @
--   $ cat dir\/index.html
--   \<p\>Hello World\<\/p\>
--   $ cat dir\/js\/test.js
--   console.log(\"hello world\");
-- @
--
-- 'createServerExp' is used like the following:
--
-- @
--   \{\-\# LANGUAGE DataKinds \#\-\}
--   \{\-\# LANGUAGE TemplateHaskell \#\-\}
--
--   type FrontEndAPI = $('Servant.Static.TH.Internal.API.createApiType' \"dir\")
--
--   frontEndServer :: 'Applicative' m => 'ServerT' FrontEndAPI m
--   frontEndServer = $('createServerExp' \"dir\")
-- @
--
-- At compile time, this expands to something like the following.  This has
-- been slightly simplified to make it easier to understand:
--
-- @
--   type FrontEndAPI =
--          \"js\" 'Servant.API.:>' \"test.js\" 'Servant.API.:>' 'Servant.API.Get' \'['JS'] 'Data.ByteString.ByteString'
--     ':<|>' 'Servant.API.Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'
--     ':<|>' \"index.html\" 'Servant.API.:>' 'Servant.API.Get' \'['Servant.HTML.Blaze.HTML'] 'Text.Blaze.Html.Html'
--
--   frontEndServer :: 'Applicative' m => 'ServerT' FrontEndAPI m
--   frontEndServer =
--          'pure' "console.log(\\"hello world\\");"
--     ':<|>' 'pure' "\<p\>Hello World\<\/p\>"
-- @
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 a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileTree -> Q Exp
fileTreeToServer NonEmpty FileTree
fileTree

-- | This is similar to 'createServerExp', but it creates the whole function
-- declaration.
--
-- Given the following code:
--
-- @
--   \{\-\# LANGUAGE DataKinds \#\-\}
--   \{\-\# LANGUAGE TemplateHaskell \#\-\}
--
--   $('createServerDec' \"FrontAPI\" \"frontServer\" \"dir\")
-- @
--
-- You can think of it as expanding to the following:
--
-- @
--   frontServer :: 'Applicative' m => 'ServerT' FrontAPI m
--   frontServer = $('createServerExp' \"dir\")
-- @
createServerDec
  :: String   -- ^ name of the api type synonym
  -> String   -- ^ name of the server function
  -> FilePath -- ^ directory name to read files from
  -> 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 :: Q Type
sigTypeQ =
          [t|forall m. Applicative m => ServerT $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (FilePath -> Name
mkName FilePath
apiName)) m|]
      signatureQ :: Q Dec
signatureQ = Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
funcName Q Type
sigTypeQ
      clauses :: [Q Clause]
clauses = [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (FilePath -> Q Exp
createServerExp FilePath
templateDir)) []]
      funcQ :: Q Dec
funcQ = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
funcName [Q Clause]
clauses
  in [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q Dec
signatureQ, Q Dec
funcQ]