{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds #-}

{-|
Module:      Servant.TypeScript.Types
Copyright:   (c) 2022 Tom McLaughlin
License:     BSD3
Stability:   experimental
Portability: portable

This library generates TypeScript client libraries for Servant.

First, make sure you have 'TypeScript' instances defined for all of the types used in the API.

@
data User = User {
  name :: String
  , age :: Int
  , email :: String
  } deriving (Eq, Show)
deriveJSONAndTypeScript A.defaultOptions ''User
@

If you need to generate lots of boilerplate instances, the functions in @aeson-typescript@'s 'Data.Aeson.TypeScript.Recursive' module can be your friend.
I've used 'Data.Aeson.TypeScript.Recursive.recursivelyDeriveMissingTypeScriptInstancesFor' to derive instances for the Kubernetes API.

Next, you'll need some Servant API:

@
type UserAPI = "users" :> Get '[JSON] [User]
          :\<|\> "albert" :> Get '[JSON] User
          :\<|\> "isaac" :> Get '[JSON] User
@

Generating the library is as simple as this:

@
main = writeTypeScriptLibrary (Proxy :: Proxy UserAPI) "\/my\/destination\/folder\/"
@

-}


module Servant.TypeScript (
  writeTypeScriptLibrary
  , writeTypeScriptLibrary'

  -- * Options
  , ServantTypeScriptOptions
  , defaultServantTypeScriptOptions
  , extraTypes
  , getFileKey
  , getFunctionName
  , getFunctions

  -- * Misc
  , MainConstraints
  ) where

import Control.Lens
import Control.Monad.Reader
import Data.Aeson.TypeScript.TH
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Proxy
import qualified Data.Set as S
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Servant.Foreign
import Servant.TypeScript.Types
import Servant.TypeScript.Util
import System.Directory
import System.FilePath


type MainConstraints api = (
  HasForeign LangTSDecls [TSDeclaration] api
  , GenerateList [TSDeclaration] (Foreign [TSDeclaration] api)
  , HasForeign LangTS T.Text api
  , GenerateList T.Text (Foreign T.Text api)
  )

-- | Write the TypeScript client library for the given API to the given folder using default options.
writeTypeScriptLibrary :: MainConstraints api => Proxy api -> FilePath -> IO ()
writeTypeScriptLibrary :: Proxy api -> FilePath -> IO ()
writeTypeScriptLibrary = ServantTypeScriptOptions -> Proxy api -> FilePath -> IO ()
forall api.
MainConstraints api =>
ServantTypeScriptOptions -> Proxy api -> FilePath -> IO ()
writeTypeScriptLibrary' ServantTypeScriptOptions
defaultServantTypeScriptOptions

-- | Write the TypeScript client library for the given API to the given folder.
writeTypeScriptLibrary' :: forall api. MainConstraints api => ServantTypeScriptOptions -> Proxy api -> FilePath -> IO ()
writeTypeScriptLibrary' :: ServantTypeScriptOptions -> Proxy api -> FilePath -> IO ()
writeTypeScriptLibrary' ServantTypeScriptOptions
opts Proxy api
_ FilePath
rootDir = (ReaderT ServantTypeScriptOptions IO ()
 -> ServantTypeScriptOptions -> IO ())
-> ServantTypeScriptOptions
-> ReaderT ServantTypeScriptOptions IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ServantTypeScriptOptions IO ()
-> ServantTypeScriptOptions -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ServantTypeScriptOptions
opts (ReaderT ServantTypeScriptOptions IO () -> IO ())
-> ReaderT ServantTypeScriptOptions IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
forall api.
(HasForeign LangTSDecls [TSDeclaration] api,
 GenerateList [TSDeclaration] (Foreign [TSDeclaration] api)) =>
Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientTypes (Proxy api
forall k (t :: k). Proxy t
Proxy @api) FilePath
rootDir
  Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
forall api.
(HasForeign LangTS Text api,
 GenerateList Text (Foreign Text api)) =>
Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientLibraries (Proxy api
forall k (t :: k). Proxy t
Proxy @api) FilePath
rootDir

writeClientTypes :: forall api. (
  HasForeign LangTSDecls [TSDeclaration] api
  , GenerateList [TSDeclaration] (Foreign [TSDeclaration] api)
  ) => Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientTypes :: Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientTypes Proxy api
_ FilePath
folder = do
  -- Types from API
  let decls :: [TSDeclaration]
decls = Set TSDeclaration -> [TSDeclaration]
forall a. Set a -> [a]
S.toList (Set TSDeclaration -> [TSDeclaration])
-> Set TSDeclaration -> [TSDeclaration]
forall a b. (a -> b) -> a -> b
$ [TSDeclaration] -> Set TSDeclaration
forall a. Ord a => [a] -> Set a
S.fromList ([TSDeclaration] -> Set TSDeclaration)
-> [TSDeclaration] -> Set TSDeclaration
forall a b. (a -> b) -> a -> b
$ [Req [TSDeclaration]] -> [TSDeclaration]
forall a. (Eq a, Ord a) => [Req [a]] -> [a]
getAllTypesFromReqs (Proxy api -> [Req [TSDeclaration]]
forall api.
(HasForeign LangTSDecls [TSDeclaration] api,
 GenerateList [TSDeclaration] (Foreign [TSDeclaration] api)) =>
Proxy api -> [Req [TSDeclaration]]
getReqsWithDecls (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api))

  -- Extra types not mentioned in the API (used in websocket protocols)
  [TSType]
extra <- (ServantTypeScriptOptions -> [TSType])
-> ReaderT ServantTypeScriptOptions IO [TSType]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServantTypeScriptOptions -> [TSType]
extraTypes
  let decls' :: [TSDeclaration]
decls' = [[TSDeclaration]] -> [TSDeclaration]
forall a. Monoid a => [a] -> a
mconcat [Proxy a -> [TSDeclaration]
forall k (a :: k). TypeScript a => Proxy a -> [TSDeclaration]
getTypeScriptDeclarations Proxy a
x | TSType Proxy a
x <- [TSType]
extra]

  IO () -> ReaderT ServantTypeScriptOptions IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT ServantTypeScriptOptions IO ())
-> IO () -> ReaderT ServantTypeScriptOptions IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
"client.d.ts") ([TSDeclaration] -> FilePath
formatTSDeclarations ([TSDeclaration] -> [TSDeclaration]
forall a. Eq a => [a] -> [a]
L.nub ([TSDeclaration]
decls [TSDeclaration] -> [TSDeclaration] -> [TSDeclaration]
forall a. Semigroup a => a -> a -> a
<> [TSDeclaration]
decls')))

writeClientLibraries :: forall api. (
  HasForeign LangTS T.Text api
  , GenerateList T.Text (Foreign T.Text api)
  ) => Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientLibraries :: Proxy api -> FilePath -> ReaderT ServantTypeScriptOptions IO ()
writeClientLibraries Proxy api
_ FilePath
folder = do
  -- Write the functions
  let allEndpoints :: [Req Text]
allEndpoints = Proxy api -> [Req Text]
forall api.
(HasForeign LangTS Text api,
 GenerateList Text (Foreign Text api)) =>
Proxy api -> [Req Text]
getEndpoints (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api)
  ServantTypeScriptOptions {[TSType]
Req Text -> FilePath
Req Text -> Text
(Req Text -> Text) -> [Req Text] -> Text
getFunctions :: (Req Text -> Text) -> [Req Text] -> Text
getFunctionName :: Req Text -> Text
getFileKey :: Req Text -> FilePath
extraTypes :: [TSType]
getFunctions :: ServantTypeScriptOptions
-> (Req Text -> Text) -> [Req Text] -> Text
getFunctionName :: ServantTypeScriptOptions -> Req Text -> Text
getFileKey :: ServantTypeScriptOptions -> Req Text -> FilePath
extraTypes :: ServantTypeScriptOptions -> [TSType]
..} <- ReaderT ServantTypeScriptOptions IO ServantTypeScriptOptions
forall r (m :: * -> *). MonadReader r m => m r
ask
  let groupedMap :: Map FilePath [Req Text]
groupedMap = (Req Text -> FilePath) -> [Req Text] -> Map FilePath [Req Text]
forall k v. Ord k => (v -> k) -> [v] -> Map k [v]
groupBy Req Text -> FilePath
getFileKey [Req Text]
allEndpoints
  [(FilePath, [Req Text])]
-> ((FilePath, [Req Text])
    -> ReaderT ServantTypeScriptOptions IO ())
-> ReaderT ServantTypeScriptOptions IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map FilePath [Req Text] -> [(FilePath, [Req Text])]
forall k a. Map k a -> [(k, a)]
M.toList Map FilePath [Req Text]
groupedMap) (((FilePath, [Req Text]) -> ReaderT ServantTypeScriptOptions IO ())
 -> ReaderT ServantTypeScriptOptions IO ())
-> ((FilePath, [Req Text])
    -> ReaderT ServantTypeScriptOptions IO ())
-> ReaderT ServantTypeScriptOptions IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
fileKey, [Req Text]
reqs) -> do
    let (FilePath
dir, FilePath
_) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
fileKey
    IO () -> ReaderT ServantTypeScriptOptions IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT ServantTypeScriptOptions IO ())
-> IO () -> ReaderT ServantTypeScriptOptions IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
dir)

    let path' :: FilePath
path' = FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
fileKey
    let functionNames :: [Text]
functionNames = (Req Text -> Text) -> [Req Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Req Text -> Text
getFunctionName [Req Text]
reqs
    Bool
-> ReaderT ServantTypeScriptOptions IO ()
-> ReaderT ServantTypeScriptOptions IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Text]
functionNames Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Set Text -> Int
forall a. Set a -> Int
S.size ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
functionNames)) (ReaderT ServantTypeScriptOptions IO ()
 -> ReaderT ServantTypeScriptOptions IO ())
-> ReaderT ServantTypeScriptOptions IO ()
-> ReaderT ServantTypeScriptOptions IO ()
forall a b. (a -> b) -> a -> b
$ do
      let duplicates :: Map Text Integer
duplicates = (Map Text Integer -> Text -> Map Text Integer)
-> Map Text Integer -> [Text] -> Map Text Integer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ((Text -> Map Text Integer -> Map Text Integer)
-> Map Text Integer -> Text -> Map Text Integer
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Maybe Integer -> Maybe Integer)
-> Text -> Map Text Integer -> Map Text Integer
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (\case Maybe Integer
Nothing -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
1 :: Integer); Just Integer
x -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)))) Map Text Integer
forall a. Monoid a => a
mempty [Text]
functionNames
      FilePath -> ReaderT ServantTypeScriptOptions IO ()
forall a. HasCallStack => FilePath -> a
error [i|Duplicate function names found when trying to generate '#{path'}': #{M.filter (>= 2) duplicates}|]

    IO () -> ReaderT ServantTypeScriptOptions IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT ServantTypeScriptOptions IO ())
-> IO () -> ReaderT ServantTypeScriptOptions IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile FilePath
path' ((Req Text -> Text) -> [Req Text] -> Text
getFunctions Req Text -> Text
getFunctionName [Req Text]
reqs)
  where
    groupBy :: Ord k => (v -> k) -> [v] -> M.Map k [v]
    groupBy :: (v -> k) -> [v] -> Map k [v]
groupBy v -> k
key [v]
as = ([v] -> [v] -> [v]) -> [(k, [v])] -> Map k [v]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [v] -> [v] -> [v]
forall a. [a] -> [a] -> [a]
(++) [(k, [v])]
as'
      where as' :: [(k, [v])]
as' = (v -> (k, [v])) -> [v] -> [(k, [v])]
forall a b. (a -> b) -> [a] -> [b]
map ((,) (k -> [v] -> (k, [v])) -> (v -> k) -> v -> [v] -> (k, [v])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v -> k
key (v -> [v] -> (k, [v])) -> (v -> [v]) -> v -> (k, [v])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v -> [v] -> [v]
forall a. a -> [a] -> [a]
:[])) [v]
as

getReqsWithDecls :: (HasForeign LangTSDecls [TSDeclaration] api, GenerateList [TSDeclaration] (Foreign [TSDeclaration] api))
  => Proxy api -> [Req [TSDeclaration]]
getReqsWithDecls :: Proxy api -> [Req [TSDeclaration]]
getReqsWithDecls = Proxy LangTSDecls
-> Proxy [TSDeclaration] -> Proxy api -> [Req [TSDeclaration]]
forall k (lang :: k) ftype api.
(HasForeign lang ftype api,
 GenerateList ftype (Foreign ftype api)) =>
Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]
listFromAPI (Proxy LangTSDecls
forall k (t :: k). Proxy t
Proxy :: Proxy LangTSDecls) (Proxy [TSDeclaration]
forall k (t :: k). Proxy t
Proxy :: Proxy [TSDeclaration])

getAllTypesFromReqs :: forall a. (Eq a, Ord a) => [Req [a]] -> [a]
getAllTypesFromReqs :: [Req [a]] -> [a]
getAllTypesFromReqs [Req [a]]
reqs = Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vals
  where [a]
vals :: [a] = [[a]] -> [a]
forall a. Monoid a => [a] -> a
mconcat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ [[[a]]] -> [[a]]
forall a. Monoid a => [a] -> a
mconcat [[Maybe [a]] -> [[a]]
forall a. [Maybe a] -> [a]
catMaybes [Req [a]
req Req [a] -> Getting (Maybe [a]) (Req [a]) (Maybe [a]) -> Maybe [a]
forall s a. s -> Getting a s a -> a
^. Getting (Maybe [a]) (Req [a]) (Maybe [a])
forall ftype. Lens' (Req ftype) (Maybe ftype)
reqReturnType, Req [a]
req Req [a] -> Getting (Maybe [a]) (Req [a]) (Maybe [a]) -> Maybe [a]
forall s a. s -> Getting a s a -> a
^. Getting (Maybe [a]) (Req [a]) (Maybe [a])
forall ftype. Lens' (Req ftype) (Maybe ftype)
reqBody]
                                          [[a]] -> [[a]] -> [[a]]
forall a. Semigroup a => a -> a -> a
<> Url [a] -> [[a]]
forall b. Url b -> [b]
getTypesFromUrl (Req [a]
req Req [a] -> Getting (Url [a]) (Req [a]) (Url [a]) -> Url [a]
forall s a. s -> Getting a s a -> a
^. Getting (Url [a]) (Req [a]) (Url [a])
forall ftype. Lens' (Req ftype) (Url ftype)
reqUrl)
                                          [[a]] -> [[a]] -> [[a]]
forall a. Semigroup a => a -> a -> a
<> (HeaderArg [a] -> [[a]]) -> [HeaderArg [a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderArg [a] -> [[a]]
forall a. HeaderArg a -> [a]
getTypesFromHeaderArg (Req [a]
req Req [a]
-> Getting [HeaderArg [a]] (Req [a]) [HeaderArg [a]]
-> [HeaderArg [a]]
forall s a. s -> Getting a s a -> a
^. Getting [HeaderArg [a]] (Req [a]) [HeaderArg [a]]
forall ftype. Lens' (Req ftype) [HeaderArg ftype]
reqHeaders)
                                        | Req [a]
req <- [Req [a]]
reqs]
        getTypesFromUrl :: Url b -> [b]
getTypesFromUrl (Url Path b
path' [QueryArg b]
queryArgs Maybe b
_) = (Segment b -> [b]) -> Path b -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Segment b -> [b]
forall a. Segment a -> [a]
getTypesFromSegment Path b
path' [b] -> [b] -> [b]
forall a. Semigroup a => a -> a -> a
<> (QueryArg b -> [b]) -> [QueryArg b] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap QueryArg b -> [b]
forall a. QueryArg a -> [a]
getTypesFromQueryArg [QueryArg b]
queryArgs
        getTypesFromSegment :: Segment a -> [a]
getTypesFromSegment (Segment (Static {})) = []
        getTypesFromSegment (Segment (Cap Arg a
arg)) = [Arg a
arg Arg a -> Getting a (Arg a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (Arg a) a
forall ftype1 ftype2. Lens (Arg ftype1) (Arg ftype2) ftype1 ftype2
argType]

        getTypesFromQueryArg :: QueryArg a -> [a]
getTypesFromQueryArg QueryArg a
queryArg = [QueryArg a
queryArg QueryArg a -> Getting a (QueryArg a) a -> a
forall s a. s -> Getting a s a -> a
^. ((Arg a -> Const a (Arg a)) -> QueryArg a -> Const a (QueryArg a)
forall ftype1 ftype2.
Lens (QueryArg ftype1) (QueryArg ftype2) (Arg ftype1) (Arg ftype2)
queryArgName ((Arg a -> Const a (Arg a)) -> QueryArg a -> Const a (QueryArg a))
-> ((a -> Const a a) -> Arg a -> Const a (Arg a))
-> Getting a (QueryArg a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> Arg a -> Const a (Arg a)
forall ftype1 ftype2. Lens (Arg ftype1) (Arg ftype2) ftype1 ftype2
argType)]

        getTypesFromHeaderArg :: HeaderArg a -> [a]
getTypesFromHeaderArg HeaderArg a
ha = [HeaderArg a
ha HeaderArg a -> Getting a (HeaderArg a) a -> a
forall s a. s -> Getting a s a -> a
^. ((Arg a -> Const a (Arg a)) -> HeaderArg a -> Const a (HeaderArg a)
forall ftype1 ftype2.
Lens
  (HeaderArg ftype1) (HeaderArg ftype2) (Arg ftype1) (Arg ftype2)
headerArg ((Arg a -> Const a (Arg a))
 -> HeaderArg a -> Const a (HeaderArg a))
-> ((a -> Const a a) -> Arg a -> Const a (Arg a))
-> Getting a (HeaderArg a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> Arg a -> Const a (Arg a)
forall ftype1 ftype2. Lens (Arg ftype1) (Arg ftype2) ftype1 ftype2
argType)]

getEndpoints :: (HasForeign LangTS T.Text api, GenerateList T.Text (Foreign T.Text api)) => Proxy api -> [Req T.Text]
getEndpoints :: Proxy api -> [Req Text]
getEndpoints = Proxy LangTS -> Proxy Text -> Proxy api -> [Req Text]
forall k (lang :: k) ftype api.
(HasForeign lang ftype api,
 GenerateList ftype (Foreign ftype api)) =>
Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]
listFromAPI (Proxy LangTS
forall k (t :: k). Proxy t
Proxy :: Proxy LangTS) (Proxy Text
forall k (t :: k). Proxy t
Proxy :: Proxy T.Text)