servant-elm (empty) → 0.1.0.0
raw patch · 8 files changed
+535/−0 lines, 8 filesdep +aesondep +basedep +data-defaultsetup-changed
Dependencies added: aeson, base, data-default, elm-export, hspec, lens, servant, servant-elm, servant-foreign, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- servant-elm.cabal +46/−0
- src/Servant/Elm.hs +11/−0
- src/Servant/Elm/Client.hs +159/−0
- src/Servant/Elm/Generate.hs +149/−0
- src/Servant/Elm/Request.hs +82/−0
- test/Spec.hs +56/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Matt Bray (c) 2015-2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matt Bray nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-elm.cabal view
@@ -0,0 +1,46 @@+name: servant-elm+version: 0.1.0.0+synopsis: Automatically derive Elm functions to query servant webservices.+description: Please see README.md+homepage: http://github.com/mattjbray/servant-elm#readme+license: BSD3+license-file: LICENSE+author: Matt Bray+maintainer: mattjbray@gmail.com+copyright: 2015-2016 Matt Bray+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Servant.Elm+ other-modules: Servant.Elm.Client+ , Servant.Elm.Generate+ , Servant.Elm.Request+ build-depends: base >= 4.7 && < 5+ , lens+ , servant == 0.5.*+ , servant-foreign == 0.5.*+ , text+ , elm-export+ default-language: Haskell2010++test-suite servant-elm-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: aeson+ , base+ , data-default+ , elm-export+ , hspec+ , servant+ , servant-elm+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mattjbray/servant-elm
+ src/Servant/Elm.hs view
@@ -0,0 +1,11 @@+module Servant.Elm+ ( generateElmForAPI+ , generateElmForAPIWith+ , ElmOptions(..)+ , defElmOptions+ , defElmImports+ ) where++import Servant.Elm.Generate (ElmOptions (..), defElmImports,+ defElmOptions, generateElmForAPI,+ generateElmForAPIWith)
+ src/Servant/Elm/Client.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Elm.Client where++import Data.Proxy (Proxy (Proxy))+import qualified Data.Text as T+import Elm (ToElmType, toElmDecoderWithSources,+ toElmEncoderWithSources,+ toElmTypeWithSources)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Servant.API ((:<|>), (:>), Capture, Get, Post,+ QueryFlag, QueryParam, QueryParams,+ ReqBody)+import Servant.Foreign (ArgType (..), QueryArg (..), Segment (..),+ SegmentType (..))++import Servant.Elm.Request (Request (..), addArgName, addDecoderDefs,+ addEncoderDefs, addFnName, addFnSignature,+ addTypeDefs, addUrlQueryStr,+ addUrlSegment, defRequest, setBodyEncoder,+ setDecoder, setHttpMethod)+++elmClient :: (HasElmClient layout)+ => Proxy layout -> [Request]+elmClient p = elmClientWithRoute p defRequest+++class HasElmClient layout where+ elmClientWithRoute :: Proxy layout -> Request -> [Request]+++-- a :<|> b+instance (HasElmClient a, HasElmClient b) => HasElmClient (a :<|> b) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy a) result +++ elmClientWithRoute (Proxy :: Proxy b) result+++-- path :> rest+instance (KnownSymbol path, HasElmClient sublayout) => HasElmClient (path :> sublayout) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addFnName p . addUrlSegment segment) result)+ where p = symbolVal (Proxy :: Proxy path)+ segment = Segment (Static (T.pack p))+++-- Capture name ArgType :> rest+instance (KnownSymbol capture, ToElmType a, HasElmClient sublayout)+ => HasElmClient (Capture capture a :> sublayout) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addTypeDefs tDefs+ . addFnSignature typeName+ . addFnName "by"+ . addArgName argName+ . addUrlSegment (Segment (Cap (T.pack argName, T.pack typeName)))) result)+ where argProxy = Proxy :: Proxy a+ argName = symbolVal (Proxy :: Proxy capture)+ (typeName, tDefs) = toElmTypeWithSources argProxy+++-- QueryFlag name :> rest+instance (KnownSymbol sym, HasElmClient sublayout)+ => HasElmClient (QueryFlag sym :> sublayout) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addArgName argName+ . addFnSignature typeName+ . addUrlQueryStr (QueryArg (T.pack argName, T.pack typeName) Flag)) result)+ where argName = symbolVal (Proxy :: Proxy sym)+ (typeName, _) = toElmTypeWithSources (Proxy :: Proxy Bool)+++-- QueryParams name ArgType :> rest+instance (KnownSymbol sym, ToElmType a, HasElmClient sublayout)+ => HasElmClient (QueryParams sym a :> sublayout) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addArgName argName+ . addTypeDefs tDefs+ . addFnSignature typeName+ . addUrlQueryStr (QueryArg (T.pack argName, T.pack typeName) List)) result)+ where argName = symbolVal (Proxy :: Proxy sym)+ (typeName, tDefs) = toElmTypeWithSources (Proxy :: Proxy [a])+++-- QueryParam name ArgType :> rest+instance (KnownSymbol sym, ToElmType a, HasElmClient sublayout)+ => HasElmClient (QueryParam sym a :> sublayout) where+ elmClientWithRoute Proxy result =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addArgName argName+ . addTypeDefs tDefs+ . addFnSignature typeName+ . addUrlQueryStr (QueryArg (T.pack argName, T.pack typeName) Normal)) result)+ where argName = symbolVal (Proxy :: Proxy sym)+ (typeName, tDefs) = toElmTypeWithSources (Proxy :: Proxy (Maybe a))+++-- ReqBody '[cts] BodyType :> rest+instance (ToElmType body, HasElmClient sublayout)+ => HasElmClient (ReqBody (ct ': cts) body :> sublayout) where+ elmClientWithRoute Proxy request =+ elmClientWithRoute (Proxy :: Proxy sublayout)+ ((addArgName "body"+ . addTypeDefs typeDefs+ . addFnSignature typeName+ . setBodyEncoder bodyEncoder+ . addEncoderDefs encoderDefs) request)+ where (typeName, typeDefs) = toElmTypeWithSources (Proxy :: Proxy body)+ (bodyEncoder, encoderDefs) = toElmEncoderWithSources (Proxy :: Proxy body)+++-- Get '[cts] RequestType+instance {-# OVERLAPPABLE #-} (ToElmType apiRequest) => HasElmClient (Get (ct ': cts) apiRequest) where+ elmClientWithRoute Proxy request =+ [completeRequestWithType (Proxy :: Proxy apiRequest) "GET" request]+++-- Get '[cts] ()+instance {-# OVERLAPPING #-} HasElmClient (Get (ct ': cts) ()) where+ elmClientWithRoute Proxy request =+ [completeRequest "GET" request]+++-- Post '[cts] RequestType+instance {-# OVERLAPPABLE #-} (ToElmType apiRequest) => HasElmClient (Post (ct ': cts) apiRequest) where+ elmClientWithRoute Proxy request =+ [completeRequestWithType (Proxy :: Proxy apiRequest) "POST" request]+++-- Post '[cts] ()+instance {-# OVERLAPPING #-} HasElmClient (Post (ct ': cts) ()) where+ elmClientWithRoute Proxy request =+ [completeRequest "POST" request]+++completeRequestWithType :: ToElmType a => Proxy a -> String -> Request -> Request+completeRequestWithType proxy method =+ setHttpMethod method+ . addFnSignature typeName+ . addTypeDefs typeDefs+ . addDecoderDefs decDefs+ . setDecoder dec+ where+ (dec, decDefs) = toElmDecoderWithSources proxy+ (typeName, typeDefs) = toElmTypeWithSources proxy+++completeRequest :: String -> Request -> Request+completeRequest method =+ setHttpMethod method+ . addFnSignature "()"+ . setDecoder "(succeed ())"
+ src/Servant/Elm/Generate.hs view
@@ -0,0 +1,149 @@+module Servant.Elm.Generate where++import Data.Char (toLower)+import Data.List (intercalate, nub)+import Data.Maybe (catMaybes)+import Data.Proxy (Proxy)+import qualified Data.Text as T+import Servant.Elm.Client (HasElmClient, elmClient)+import Servant.Elm.Request (Request (..))+import Servant.Foreign (ArgType (..), QueryArg (..), Segment (..),+ SegmentType (..), camelCase)+++data ElmOptions = ElmOptions+ { urlPrefix :: String }+++defElmOptions :: ElmOptions+defElmOptions = ElmOptions+ { urlPrefix = "" }+++defElmImports :: String+defElmImports =+ unlines+ [ "import Json.Decode exposing ((:=))"+ , "import Json.Decode.Extra exposing ((|:))"+ , "import Json.Encode"+ , "import Http"+ , "import String"+ , "import Task"+ ]+++generateElmForAPI :: (HasElmClient layout)+ => Proxy layout -> [String]+generateElmForAPI = generateElmForAPIWith defElmOptions+++generateElmForAPIWith :: (HasElmClient layout)+ => ElmOptions -> Proxy layout -> [String]+generateElmForAPIWith opts = nub . concatMap (generateElmForRequest opts) . elmClient+++-- TODO: headers, content type?, url encoders?+generateElmForRequest :: ElmOptions -> Request -> [String]+generateElmForRequest opts request = typeDefs request ++ decoderDefs request ++ encoderDefs request ++ [func]+ where func = funcName ++ " : " ++ (typeSignature . reverse . fnSignature) request ++ "\n"+ ++ funcNameArgs ++ " =\n"+ ++ " let\n"+ ++ letParams " "+ ++ " request =\n"+ ++ " { verb =\n"+ ++ " \"" ++ httpMethod request ++ "\"\n"+ ++ " , headers =\n"+ ++ " [(\"Content-Type\", \"application/json\")]\n"+ ++ " , url =\n"+ ++ " " ++ url ++ "\n"+ ++ urlParams " "+ ++ " , body =\n"+ ++ " " ++ body ++ "\n"+ ++ " }\n"+ ++ " in\n"+ ++ " Http.fromJson\n"+ ++ " " ++ decoder request ++ "\n"+ ++ " (Http.send Http.defaultSettings request)"+ funcName = (T.unpack . camelCase . map T.pack . (:) (map toLower (httpMethod request)) . reverse) (fnName request)+ typeSignature [x] = "Task.Task Http.Error (" ++ x ++ ")"+ typeSignature (x:xs) = x ++ " -> " ++ typeSignature xs+ typeSignature [] = ""+ funcNameArgs = unwords (funcName : args)+ url = buildUrl (urlPrefix opts) segments+ args = reverse (argNames request)+ segments = (reverse . urlSegments) request+ params = (map paramToStr . reverse . urlQueryStr) request+ letParams indent =+ if null params then+ ""+ else+ indent+ ++ intercalate ("\n" ++ indent)+ [ "params ="+ , " List.filter (not << String.isEmpty)"+ , " [ " ++ intercalate ("\n" ++ indent ++ " , ") params+ , " ]"+ ]+ ++ "\n"+ urlParams indent =+ if null params then+ ""+ else+ indent+ ++ intercalate ("\n" ++ indent)+ [ "++ if List.isEmpty params then"+ , " \"\""+ , " else"+ , " \"?\" ++ String.join \"&\" params"+ ]+ ++ "\n"+ body = case bodyEncoder request of+ Just encoder -> "Http.string (Json.Encode.encode 0 (" ++ encoder ++ " body))"+ Nothing -> "Http.empty"+++buildUrl :: String -> [Segment] -> String+buildUrl prefix segments =+ (intercalate newLine . catMaybes)+ [ nullOr prefix $+ "\"" ++ prefix ++ "\""+ , nullOr segments $+ "\"/\" ++ "+ ++ intercalate (newLine ++ "\"/\" ++ ")+ (map segmentToStr segments)+ ]+ where newLine = "\n ++ "+ nullOr t x = if null t+ then Nothing+ else Just x+++segmentToStr :: Segment -> String+segmentToStr (Segment (Static s)) = "\"" ++ T.unpack s ++ "\""+segmentToStr (Segment (Cap (s, _))) = "(" ++ T.unpack s ++ " |> toString |> Http.uriEncode)"+++paramToStr :: QueryArg -> String+paramToStr qarg =+ case _argType qarg of+ Normal ->+ intercalate newLine+ [ name+ , " |> Maybe.map (toString >> Http.uriEncode >> (++) \"" ++ name ++ "=\")"+ , " |> Maybe.withDefault \"\""+ ]+ Flag ->+ intercalate newLine+ ["if " ++ name ++ " then"+ , " \"" ++ name ++ "=\""+ , "else"+ , " \"\""+ ]+ List ->+ intercalate newLine+ [ name+ , " |> List.map (\\val -> \"" ++ name ++ "[]=\" ++ (val |> toString |> Http.uriEncode))"+ , " |> String.join \"&\""+ ]+ where name = T.unpack (fst (_argName qarg))+ newLine = "\n "
+ src/Servant/Elm/Request.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeOperators #-}++module Servant.Elm.Request where++import Servant.Foreign (QueryArg, Segment)+++data Request = Request+ { typeDefs :: [String]+ , decoderDefs :: [String]+ , encoderDefs :: [String]+ , decoder :: String+ , fnName :: [String]+ , fnSignature :: [String]+ , urlSegments :: [Segment]+ , urlQueryStr :: [QueryArg]+ , httpMethod :: String+ , argNames :: [String]+ , bodyEncoder :: Maybe String+ } deriving (Show)+++defRequest :: Request+defRequest = Request+ { typeDefs = []+ , decoderDefs = []+ , encoderDefs = []+ , decoder = ""+ , fnName = []+ , fnSignature = []+ , httpMethod = "GET"+ , urlSegments = []+ , urlQueryStr = []+ , argNames = []+ , bodyEncoder = Nothing+ }+++addTypeDefs :: [String] -> Request -> Request+addTypeDefs elmTypes request = request { typeDefs = typeDefs request ++ elmTypes }+++addFnName :: String -> Request -> Request+addFnName name request = request { fnName = name : fnName request }+++addUrlSegment :: Segment -> Request -> Request+addUrlSegment segment request = request { urlSegments = segment : urlSegments request }+++addUrlQueryStr :: QueryArg -> Request -> Request+addUrlQueryStr arg request = request { urlQueryStr = arg : urlQueryStr request }+++-- TODO: perhaps we could get rid of most of the fnSignature stuff now that+-- servant-foreign allows us to keep it in their Arg type.+addFnSignature :: String -> Request -> Request+addFnSignature name request = request { fnSignature = name : fnSignature request }+++setDecoder :: String -> Request -> Request+setDecoder dec request = request { decoder = dec }+++addDecoderDefs :: [String] -> Request -> Request+addDecoderDefs defs request = request { decoderDefs = decoderDefs request ++ defs }+++addArgName :: String -> Request -> Request+addArgName name request = request { argNames = name : argNames request }+++setHttpMethod :: String -> Request -> Request+setHttpMethod method request = request { httpMethod = method }+++setBodyEncoder :: String -> Request -> Request+setBodyEncoder encoder request = request { bodyEncoder = Just encoder }+++addEncoderDefs :: [String] -> Request -> Request+addEncoderDefs defs request = request { encoderDefs = encoderDefs request ++ defs }
+ test/Spec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++import Test.Hspec++import Control.Monad (zipWithM_)+import Data.Aeson (ToJSON)+import Data.Default (Default, def)+import Data.Proxy (Proxy(Proxy))+import Elm (ToElmType)+import GHC.Generics (Generic)+import Servant.API+import Servant.Elm+++data Book = Book+ { title :: String+ } deriving Generic++instance ToJSON Book+instance ToElmType Book+++type TestApi = "one" :> Get '[JSON] Int+ :<|> "two" :> ReqBody '[JSON] String :> Post '[JSON] (Maybe Int)+ :<|> "books" :> Capture "id" Int :> Get '[JSON] Book+ :<|> "books" :> QueryFlag "published"+ :> QueryParam "sort" String+ :> QueryParams "filters" (Maybe Bool)+ :> Get '[JSON] [Book]++main :: IO ()+main = hspec $+ describe "encoding a simple api" $+ it "does it" $ do+ getOneSource <- readFile "test/getOneSource.elm"+ postTwoSource <- readFile "test/postTwoSource.elm"+ bookTypeSource <- readFile "test/bookTypeSource.elm"+ decodeBookSource <- readFile "test/decodeBookSource.elm"+ getBooksBySource <- readFile "test/getBooksBySource.elm"+ getBooksSource <- readFile "test/getBooksSource.elm"+ let generated = map (++ "\n") (generateElmForAPI (Proxy :: Proxy TestApi))+ expected = [ getOneSource+ , postTwoSource+ , bookTypeSource+ , decodeBookSource+ , getBooksBySource+ , getBooksSource+ ]+ generated `itemsShouldBe` expected++itemsShouldBe :: (Default a, Eq a, Show a) => [a] -> [a] -> IO ()+itemsShouldBe actual expected =+ zipWithM_ shouldBe (actual ++ replicate (length expected - length actual) def)+ (expected ++ replicate (length actual - length expected) def)