diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ ## Unreleased changes +## 0.4.2.0 + +- Use the `Url.Builder` module from `elm/url` to build URLs (https://github.com/folq/servant-to-elm/pull/6 by https://github.com/rl-king) +- Update `haskell-to-elm` bounds to latest version 0.3.2 + ## 0.4.1.0 - Update to `elm-syntax-0.3.0.0` and `haskell-to-elm-0.3.0.0`, adding support for parameterised types diff --git a/servant-to-elm.cabal b/servant-to-elm.cabal --- a/servant-to-elm.cabal +++ b/servant-to-elm.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.34.3. -- -- see: https://github.com/sol/hpack -- --- hash: 76dda62e30819622cd48fbd148358cdb0b25fddec8951c2cca91efd425813fcb +-- hash: 600be4c131caa5290786ee59b7f6bb34535ebd50ff0b013c8529535fae575747 name: servant-to-elm -version: 0.4.1.0 +version: 0.4.2.0 synopsis: Automatically generate Elm clients for Servant APIs description: Please see the README on GitHub at category: Servant, API, Elm, Compiler @@ -18,7 +18,8 @@ copyright: 2019 Olle Fredriksson license: BSD3 license-file: LICENSE -tested-with: GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3 +tested-with: + GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3 build-type: Simple extra-source-files: README.md @@ -46,9 +47,9 @@ , base >=4.7 && <5 , bound >=2.0.0 , elm-syntax >=0.3.0 && <0.3.1 - , haskell-to-elm >=0.3.0 && <0.3.1 + , haskell-to-elm >=0.3.0 && <0.3.3 , http-types >=0.12.0 - , servant >=0.16.0 + , servant >=0.16.0 && <0.17.0 , servant-multipart >=0.11.0 , text >=1.2.0 default-language: Haskell2010 @@ -66,7 +67,7 @@ , bound >=2.0.0 , elm-syntax >=0.3.0 && <0.3.1 , generics-sop - , haskell-to-elm >=0.3.0 && <0.3.1 + , haskell-to-elm >=0.3.0 && <0.3.3 , http-types >=0.12.0 , servant , servant-multipart >=0.11.0 @@ -81,6 +82,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + TestExampleServer Paths_servant_to_elm hs-source-dirs: test @@ -89,11 +91,20 @@ aeson >=1.4.0 , base >=4.7 && <5 , bound >=2.0.0 + , bytestring >=0.10 + , directory >=1.3 , elm-syntax >=0.3.0 && <0.3.1 - , haskell-to-elm >=0.3.0 && <0.3.1 + , filepath >=1.4 + , generics-sop >=0.4 + , haskell-to-elm >=0.3.0 && <0.3.3 + , hspec >=2.7 , http-types >=0.12.0 - , servant >=0.16.0 + , prettyprinter >=1.2 + , process >=1.6 + , servant >=0.16.0 && <0.17.0 , servant-multipart >=0.11.0 , servant-to-elm + , temporary >=1.3 , text >=1.2.0 + , unordered-containers >=0.2 default-language: Haskell2010 diff --git a/src/Servant/To/Elm.hs b/src/Servant/To/Elm.hs --- a/src/Servant/To/Elm.hs +++ b/src/Servant/To/Elm.hs @@ -13,7 +13,20 @@ {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# options_ghc -fno-warn-orphans #-} -module Servant.To.Elm where +module Servant.To.Elm + ( elmEndpointDefinition + , elmEndpointRequestInfo + , HasElmEndpoints(..) + , elmEndpoints + , Endpoint(..) + , PathSegment (..) + , QueryParamType(..) + , URL(..) + , Encoder(..) + , Decoder(..) + , makeEncoder + , makeDecoder + ) where import qualified Bound import qualified Data.Aeson as Aeson @@ -42,6 +55,9 @@ import Language.Haskell.To.Elm -- | Generate an Elm function for making a request to a Servant endpoint. +-- +-- See 'elmEndpointRequestInfo' if you need more flexibility, +-- such as setting timeouts. elmEndpointDefinition :: Expression Void -- ^ The URL base of the endpoint -> Name.Module -- ^ The module that the function should be generated into @@ -49,27 +65,11 @@ -> Definition elmEndpointDefinition urlBase moduleName endpoint = Definition.Constant - (Name.Qualified moduleName functionName) + (Name.Qualified moduleName (functionName endpoint)) 0 (Bound.toScope $ vacuous $ elmTypeSig) - (error "expression not closed" <$> lambdaArgs argNames elmLambdaBody) + (error "expression not closed" <$> lambdaArgs (argNames endpoint) elmLambdaBody) where - functionName = - case _functionName endpoint of - [] -> - "" - - firstPart:rest -> - firstPart <> foldMap capitalise rest - - capitalise s = - case Text.uncons s of - Nothing -> - "" - - Just (c, s') -> - Text.cons (Char.toUpper c) s' - elmTypeSig :: Type Void elmTypeSig = Type.funs @@ -78,7 +78,7 @@ | (_, arg, _) <- _headers endpoint ] , [ _encodedType arg - | Capture _ (_, arg) <- numberedPathSegments + | Capture _ (_, arg) <- numberedPathSegments endpoint ] , [ case type_ of Required -> @@ -121,264 +121,124 @@ [Type.tuple "Http.Error" (Type.App "Maybe.Maybe" $ Type.Record [("metadata", "Http.Metadata"), ("body", "String.String")]), type_] ) - numberedPathSegments = - go 0 $ _path $ _url endpoint - where - go !i segments = - case segments of - [] -> - [] - - Static p:segments' -> - Static p : go i segments' - - Capture str arg:segments' -> - Capture str (i, arg) : go (i + 1) segments' - - argNames = - concat - [ [ headerArgName i - | (i, _) <- zip [0..] $ _headers endpoint - ] - , [ capturedArgName i - | Capture _ (i, _) <- numberedPathSegments - ] - , [ paramArgName i - | (i, _) <- zip [0..] $ _queryString $ _url endpoint - ] - , [ bodyArgName - | Just _ <- [_body endpoint] - ] - ] - - lambdaArgs :: [Text] -> Expression Text -> Expression Text - lambdaArgs args rhs = - case args of - [] -> - rhs - - arg:args' -> - Expression.Lam $ Bound.abstract1 arg $ lambdaArgs args' rhs - elmLambdaBody :: Expression Text elmLambdaBody = Expression.App "Http.request" (Expression.Record [ ("method", Expression.String $ Text.decodeUtf8 $ _method endpoint) - , ("headers", elmHeaders) + , ("headers", elmHeaders endpoint) , ("url", elmUrl) - , ("body", elmBody) - , ("expect", elmExpect) + , ("body", elmBody endpoint) + , ("expect", elmExpect endpoint) , ("timeout", "Maybe.Nothing") , ("tracker", "Maybe.Nothing") ] ) - elmParams = - [ case type_ of - Required -> - Expression.List - [Expression.String (name <> "=") Expression.++ encode (pure $ paramArgName i)] - - Optional -> - Expression.apps - "Maybe.Extra.unwrap" - [ Expression.List [] - , "List.singleton" Expression.<< Expression.App "Basics.++" (Expression.String $ name <> "=") - , encode $ pure $ paramArgName i - ] - - Flag -> - Expression.if_ - (pure $ paramArgName i) - (Expression.List [Expression.String name]) - (Expression.List []) - - List -> - Expression.apps - "List.map" - [ Expression.App "Basics.++" (Expression.String (name <> "[]=")) Expression.<< encoder - , pure $ paramArgName i - ] - | (i, (name, type_, arg)) <- zip [0..] $ _queryString $ _url endpoint - , let - encoder = - vacuous $ _encoder arg - - encode = - Expression.App encoder - ] - elmUrl = - case elmParams of - [] -> - withoutParams - - [elmParams'] -> - withParams elmParams' - - _ -> - withParams (Expression.App "List.concat" $ Expression.List elmParams) + Expression.apps + "Url.Builder.crossOrigin" + [ vacuous urlBase + , Expression.List $ fmap elmPathSegment (numberedPathSegments endpoint) + , Expression.App "List.concat" $ Expression.List (elmParams endpoint) + ] - where - withoutParams = - Expression.apps - "String.join" - [ Expression.String "/" - , Expression.List $ vacuous urlBase : fmap elmPathSegment numberedPathSegments +-- | Generate an Elm function for creating information needed to make an HTTP request. +-- This gives the user flexibility in how to actually make the request. +-- +-- For example, they can use the +-- function and provide it with their own @timeout@ and @tracker@ arguments. +-- +-- It also leaves building the final URL to the Elm user. +-- This gives them the flexibility to do things like vary the domain used at runtime +-- based on whether the app's in staging or production. +-- Note that they must remember to use BOTH @urlPath@ and @urlQueryParams@. +elmEndpointRequestInfo + :: Name.Module -- ^ The module that the function should be generated into + -> Endpoint -- ^ A description of the endpoint + -> Definition +elmEndpointRequestInfo moduleName endpoint = + Definition.Constant + (Name.Qualified moduleName (functionName endpoint)) + 0 + (Bound.toScope $ vacuous $ elmTypeSig) + (error "expression not closed" <$> lambdaArgs (argNames endpoint) elmLambdaBody) + where + elmTypeSig :: Type Void + elmTypeSig = + Type.funs + (concat + [ [ _encodedType arg + | (_, arg, _) <- _headers endpoint ] - - withParams params = - withoutParams Expression.++ - Expression.Case params - [ (Pattern.List [], Bound.toScope $ Expression.String "") - , ( Pattern.Var 0 - , Bound.toScope $ Expression.String "?" Expression.++ Expression.apps "String.join" [Expression.String "&", pure $ Bound.B 0] - ) - ] + , [ _encodedType arg + | Capture _ (_, arg) <- numberedPathSegments endpoint + ] + , [ case type_ of + Required -> + vacuous $ _encodedType arg + Optional -> + vacuous $ _encodedType arg - elmHeaders = - let - headerDecoder i name arg = - Expression.apps - "Http.header" - [ Expression.String name - , Expression.App - (vacuous $ _encoder arg) - (pure $ headerArgName i) - ] + Flag -> + vacuous $ _encodedType arg - optionalHeaderDecoder i name arg = - Expression.apps - "Maybe.map" - [ Expression.App - "Http.header" - (Expression.String name) - , Expression.App - (vacuous $ _encoder arg) - (pure $ headerArgName i) + List -> + vacuous $ Type.App "List.List" $ _encodedType arg + | (_, type_, arg) <- _queryString $ _url endpoint ] - in - case _headers endpoint of - [] -> - Expression.List [] - - _ - | all (\(_, _, required) -> required) (_headers endpoint) -> - Expression.List - [ headerDecoder i name arg - | (i, (name, arg, _)) <- zip [0..] $ _headers endpoint + , [ _encodedType body + | Just (_, body) <- [_body endpoint] ] - - _ -> - Expression.apps "List.filterMap" - [ "Basics.identity" - , Expression.List - [ if required then - Expression.App "Maybe.Just" $ headerDecoder i name arg - - else - optionalHeaderDecoder i name arg - | (i, (name, arg, required)) <- zip [0..] $ _headers endpoint - ] ] - - - elmBody = - case _body endpoint of - Nothing -> - "Http.emptyBody" + ) + elmReturnType - Just (bodyType, body) -> - Expression.App - (vacuous bodyType) - (Expression.App (vacuous $ _encoder body) $ pure bodyArgName) + elmReturnType = + let + type_ = + case _returnType endpoint of + Nothing -> + "Basics.()" - elmExpect = - Expression.apps - "Http.expectStringResponse" - [ "Basics.identity" - , Expression.Lam $ Bound.toScope $ - Expression.Case (pure $ Bound.B ()) - [ ( Pattern.Con "Http.BadUrl_" [Pattern.Var 0] - , Bound.toScope $ - Expression.App "Result.Err" $ - Expression.tuple (Expression.App "Http.BadUrl" $ pure (Bound.B 0)) "Maybe.Nothing" - ) - , ( Pattern.Con "Http.Timeout_" [] - , Bound.toScope $ - Expression.App "Result.Err" $ - Expression.tuple "Http.Timeout" "Maybe.Nothing" - ) - , ( Pattern.Con "Http.NetworkError_" [] - , Bound.toScope $ - Expression.App "Result.Err" $ - Expression.tuple "Http.NetworkError" "Maybe.Nothing" - ) - , ( Pattern.Con "Http.BadStatus_" [Pattern.Var 0, Pattern.Var 1] - , Bound.toScope $ - Expression.App "Result.Err" $ - Expression.tuple - (Expression.App "Http.BadStatus" (Expression.App (Expression.Proj "statusCode") $ pure $ Bound.B 0)) - (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)]) - ) - , ( Pattern.Con "Http.GoodStatus_" [Pattern.Var 0, Pattern.Var 1] - , Bound.toScope $ - case _returnType endpoint of - Nothing -> - error "elmRequest: No return type" -- TODO? + Just (Left Servant.NoContent) -> + "Basics.()" - Just (Left Servant.NoContent) -> - Expression.if_ (Expression.apps ("Basics.==") [pure $ Bound.B 1, Expression.String ""]) - (Expression.App "Result.Ok" "Basics.()") - (Expression.App "Result.Err" $ - Expression.tuple - (Expression.App "Http.BadBody" $ Expression.String "Expected the response body to be empty") - (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)]) - ) + Just (Right decoder) -> + _decodedType decoder - Just (Right elmReturnDecoder) -> - Expression.apps "Result.mapError" - [ Expression.Lam $ Bound.toScope $ - Expression.tuple - (Expression.App "Http.BadBody" $ - Expression.App "Json.Decode.errorToString" $ - pure $ Bound.B () - ) - (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.F $ Bound.B 0), ("body", pure $ Bound.F $ Bound.B 1)]) - , Expression.apps "Json.Decode.decodeString" [vacuous $ _decoder elmReturnDecoder, pure $ Bound.B 1] - ] - ) - ] + expectType = + Type.App + "Http.Expect" + (Type.apps + "Result.Result" + [ Type.tuple + "Http.Error" + (Type.App "Maybe.Maybe" $ Type.Record [("metadata", "Http.Metadata"), ("body", "String.String")]) + , type_ + ]) + in + Type.Record + [ ("method", "String.String") + , ("headers", Type.App "List.List" "Http.Header") + , ("urlPath", Type.App "List.List" "String.String") + , ("urlQueryParams", Type.App "List.List" "Url.Builder.QueryParameter") + , ("body", "Http.Body") + , ("expect", expectType) ] - elmPathSegment pathSegment = - case pathSegment of - Static s -> - Expression.String s - - Capture _ (i, arg) -> - Expression.App - (vacuous $ _encoder arg) - (pure $ capturedArgName i) - - bodyArgName :: Text - bodyArgName = - "body" - - headerArgName :: Int -> Text - headerArgName i = - "header" <> fromString (show i) - - capturedArgName :: Int -> Text - capturedArgName i = - "capture" <> fromString (show i) - - paramArgName :: Int -> Text - paramArgName i = - "param" <> fromString (show i) + elmLambdaBody :: Expression Text + elmLambdaBody = + Expression.Record + [ ("method", Expression.String $ Text.decodeUtf8 $ _method endpoint) + , ("headers", elmHeaders endpoint) + , ("urlPath", Expression.List (fmap elmPathSegment (numberedPathSegments endpoint))) + , ("urlQueryParams", Expression.List (elmParams endpoint)) + , ("body", elmBody endpoint) + , ("expect", elmExpect endpoint) + ] ------------------------------------------------------------------------------- -- * Endpoints @@ -635,3 +495,255 @@ instance HasElmEncoder (Servant.MultipartData tag) (Servant.MultipartData tag) where elmEncoder = "Basics.identity" + +------------------------------------------------------------------------------- +-- * Internal + +elmHeaders :: Endpoint -> Expression Text +elmHeaders endpoint = + let + headerDecoder i name arg = + Expression.apps + "Http.header" + [ Expression.String name + , Expression.App + (vacuous $ _encoder arg) + (pure $ headerArgName i) + ] + + optionalHeaderDecoder i name arg = + Expression.apps + "Maybe.map" + [ Expression.App + "Http.header" + (Expression.String name) + , Expression.App + (vacuous $ _encoder arg) + (pure $ headerArgName i) + ] + in + case _headers endpoint of + [] -> + Expression.List [] + + _ + | all (\(_, _, required) -> required) (_headers endpoint) -> + Expression.List + [ headerDecoder i name arg + | (i, (name, arg, _)) <- zip [0..] $ _headers endpoint + ] + + _ -> + Expression.apps "List.filterMap" + [ "Basics.identity" + , Expression.List + [ if required then + Expression.App "Maybe.Just" $ headerDecoder i name arg + + else + optionalHeaderDecoder i name arg + | (i, (name, arg, required)) <- zip [0..] $ _headers endpoint + ] + ] + +headerArgName :: Int -> Text +headerArgName i = + "header" <> fromString (show i) + +numberedPathSegments :: Endpoint -> [PathSegment (Int, Encoder)] +numberedPathSegments endpoint = + go 0 $ _path $ _url endpoint + where + go !i segments = + case segments of + [] -> + [] + + Static p:segments' -> + Static p : go i segments' + + Capture str arg:segments' -> + Capture str (i, arg) : go (i + 1) segments' + +elmParams :: Endpoint -> [Expression Text] +elmParams endpoint = + [ case type_ of + Required -> + Expression.List + [ Expression.apps "Url.Builder.string" + [ Expression.String name, encode (pure $ paramArgName i) ] + ] + + Optional -> + Expression.apps + "Maybe.withDefault" + [ Expression.List [] + , Expression.apps "Maybe.map" + [ "List.singleton" Expression.<< + Expression.App "Url.Builder.string" (Expression.String name) + , encode $ pure $ paramArgName i + ] + ] + + Flag -> + Expression.if_ + (pure $ paramArgName i) + (Expression.List + [ Expression.apps "Url.Builder.string" + [ Expression.String name + , Expression.String "true" + ] + ] + ) + (Expression.List []) + + List -> + Expression.apps + "List.map" + [ Expression.App "Url.Builder.string" (Expression.String name) Expression.<< encoder + , pure $ paramArgName i + ] + | (i, (name, type_, arg)) <- zip [0..] $ _queryString $ _url endpoint + , let + encoder = + vacuous $ _encoder arg + + encode = + Expression.App encoder + ] + +paramArgName :: Int -> Text +paramArgName i = + "param" <> fromString (show i) + +elmPathSegment :: PathSegment (Int, Encoder) -> Expression Text +elmPathSegment pathSegment = + case pathSegment of + Static s -> + Expression.String s + + Capture _ (i, arg) -> + Expression.App + (vacuous $ _encoder arg) + (pure $ capturedArgName i) + +capturedArgName :: Int -> Text +capturedArgName i = + "capture" <> fromString (show i) + +elmBody :: Endpoint -> Expression Text +elmBody endpoint = + case _body endpoint of + Nothing -> + "Http.emptyBody" + + Just (bodyType, body) -> + Expression.App + (vacuous bodyType) + (Expression.App (vacuous $ _encoder body) $ pure bodyArgName) + +elmExpect :: Endpoint -> Expression a +elmExpect endpoint = + Expression.apps + "Http.expectStringResponse" + [ "Basics.identity" + , Expression.Lam $ Bound.toScope $ + Expression.Case (pure $ Bound.B ()) + [ ( Pattern.Con "Http.BadUrl_" [Pattern.Var 0] + , Bound.toScope $ + Expression.App "Result.Err" $ + Expression.tuple (Expression.App "Http.BadUrl" $ pure (Bound.B 0)) "Maybe.Nothing" + ) + , ( Pattern.Con "Http.Timeout_" [] + , Bound.toScope $ + Expression.App "Result.Err" $ + Expression.tuple "Http.Timeout" "Maybe.Nothing" + ) + , ( Pattern.Con "Http.NetworkError_" [] + , Bound.toScope $ + Expression.App "Result.Err" $ + Expression.tuple "Http.NetworkError" "Maybe.Nothing" + ) + , ( Pattern.Con "Http.BadStatus_" [Pattern.Var 0, Pattern.Var 1] + , Bound.toScope $ + Expression.App "Result.Err" $ + Expression.tuple + (Expression.App "Http.BadStatus" (Expression.App (Expression.Proj "statusCode") $ pure $ Bound.B 0)) + (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)]) + ) + , ( Pattern.Con "Http.GoodStatus_" [Pattern.Var 0, Pattern.Var 1] + , Bound.toScope $ + case _returnType endpoint of + Nothing -> + error "elmRequest: No return type" -- TODO? + + Just (Left Servant.NoContent) -> + Expression.if_ (Expression.apps ("Basics.==") [pure $ Bound.B 1, Expression.String ""]) + (Expression.App "Result.Ok" "Basics.()") + (Expression.App "Result.Err" $ + Expression.tuple + (Expression.App "Http.BadBody" $ Expression.String "Expected the response body to be empty") + (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.B 0), ("body", pure $ Bound.B 1)]) + ) + + Just (Right elmReturnDecoder) -> + Expression.apps "Result.mapError" + [ Expression.Lam $ Bound.toScope $ + Expression.tuple + (Expression.App "Http.BadBody" $ + Expression.App "Json.Decode.errorToString" $ + pure $ Bound.B () + ) + (Expression.App "Maybe.Just" $ Expression.Record [("metadata", pure $ Bound.F $ Bound.B 0), ("body", pure $ Bound.F $ Bound.B 1)]) + , Expression.apps "Json.Decode.decodeString" [vacuous $ _decoder elmReturnDecoder, pure $ Bound.B 1] + ] + ) + ] + ] + +bodyArgName :: Text +bodyArgName = + "body" + +lambdaArgs :: [Text] -> Expression Text -> Expression Text +lambdaArgs args rhs = + case args of + [] -> + rhs + + arg:args' -> + Expression.Lam $ Bound.abstract1 arg $ lambdaArgs args' rhs + +argNames :: Endpoint -> [Text] +argNames endpoint = + concat + [ [ headerArgName i + | (i, _) <- zip [0..] $ _headers endpoint + ] + , [ capturedArgName i + | Capture _ (i, _) <- numberedPathSegments endpoint + ] + , [ paramArgName i + | (i, _) <- zip [0..] $ _queryString $ _url endpoint + ] + , [ bodyArgName + | Just _ <- [_body endpoint] + ] + ] + +functionName :: Endpoint -> Text +functionName endpoint = + case Text.filter Char.isAlphaNum <$> _functionName endpoint of + [] -> + "" + + firstPart:rest -> + firstPart <> foldMap capitalise rest + where + capitalise s = + case Text.uncons s of + Nothing -> + "" + + Just (c, s') -> + Text.cons (Char.toUpper c) s' diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,67 @@ +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +module Main where + +import qualified Data.ByteString as BS +import Data.Foldable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Prettyprint.Doc as Pretty +import System.Directory +import System.FilePath +import System.IO.Temp +import System.Process (callCommand) +import Test.Hspec + +import qualified TestExampleServer + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = + hspec spec + +spec :: Spec +spec = do + describe "servant-to-elm" $ do + it "elmEndpointDefinition" $ + withTempDir (testElmClient TestExampleServer.definitionModules) + it "elmEndpointRequestInfo" $ + withTempDir (testElmClient TestExampleServer.requestInfoModules) + where + withTempDir = + withSystemTempDirectory + "servant-to-elm" -- temp dir name template + +testElmClient :: HashMap [Text] (Pretty.Doc ann) -> FilePath -> IO () +testElmClient elmModules tempDir = do + let srcDir = tempDir "src" + createDirectory srcDir + createDirectory (srcDir "Api") + + for_ (List.sortOn fst (HashMap.toList elmModules)) $ \(moduleName, content) -> + writeElmModule srcDir moduleName content + + copyFile ("test" "elm.json") (tempDir "elm.json") + + copyFile ("test" "Config.elm") (srcDir "Config.elm") + + compileGeneratedElm + where + compileGeneratedElm :: IO () + compileGeneratedElm = + withCurrentDirectory tempDir $ + callCommand "elm make src/**.elm" + +writeElmModule :: FilePath -> [Text] -> Pretty.Doc ann -> IO () +writeElmModule srcDir moduleName content = + BS.writeFile + path + (encodeUtf8 (Text.pack (show content))) + where + path :: FilePath + path = + foldl' () mempty (srcDir : fmap Text.unpack moduleName) + <> ".elm" diff --git a/test/TestExampleServer.hs b/test/TestExampleServer.hs new file mode 100644 --- /dev/null +++ b/test/TestExampleServer.hs @@ -0,0 +1,66 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +module TestExampleServer where + +import qualified Data.Aeson as Aeson +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import qualified Data.Text.Prettyprint.Doc as Pretty +import GHC.Generics +import qualified Generics.SOP as SOP +import qualified Language.Elm.Definition as Elm (Definition) +import qualified Language.Elm.Pretty as Pretty +import qualified Language.Elm.Simplification as Simplification +import Servant.API +import Servant.To.Elm + +import Language.Haskell.To.Elm + +data User = User + { name :: Text + , age :: Int + } deriving (Generic, Aeson.ToJSON, SOP.Generic, SOP.HasDatatypeInfo) + +instance HasElmType User where + elmDefinition = + Just $ deriveElmTypeDefinition @User defaultOptions "Api.User.User" + +instance HasElmDecoder Aeson.Value User where + elmDecoderDefinition = + Just $ deriveElmJSONDecoder @User defaultOptions Aeson.defaultOptions "Api.User.decoder" + +instance HasElmEncoder Aeson.Value User where + elmEncoderDefinition = + Just $ deriveElmJSONEncoder @User defaultOptions Aeson.defaultOptions "Api.User.encoder" + +type UserAPI + = "user" :> Get '[JSON] User + :<|> "user" :> ReqBody '[JSON] User :> PostNoContent '[JSON] NoContent + +definitionModules :: HashMap [Text] (Pretty.Doc ann) +definitionModules = + Pretty.modules (Simplification.simplifyDefinition <$> definitions) + where + definitions :: [Elm.Definition] + definitions = + map (elmEndpointDefinition "Config.urlBase" ["Api"]) (elmEndpoints @UserAPI) + <> jsonDefinitions @User + +requestInfoModules :: HashMap [Text] (Pretty.Doc ann) +requestInfoModules = + Pretty.modules (Simplification.simplifyDefinition <$> definitions) + where + definitions :: [Elm.Definition] + definitions = + map (elmEndpointRequestInfo ["Api"]) (elmEndpoints @UserAPI) + <> jsonDefinitions @User