diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-elm.cabal b/servant-elm.cabal new file mode 100644 --- /dev/null +++ b/servant-elm.cabal @@ -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 diff --git a/src/Servant/Elm.hs b/src/Servant/Elm.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Elm.hs @@ -0,0 +1,11 @@ +module Servant.Elm + ( generateElmForAPI + , generateElmForAPIWith + , ElmOptions(..) + , defElmOptions + , defElmImports + ) where + +import Servant.Elm.Generate (ElmOptions (..), defElmImports, + defElmOptions, generateElmForAPI, + generateElmForAPIWith) diff --git a/src/Servant/Elm/Client.hs b/src/Servant/Elm/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Elm/Client.hs @@ -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 ())" diff --git a/src/Servant/Elm/Generate.hs b/src/Servant/Elm/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Elm/Generate.hs @@ -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 " diff --git a/src/Servant/Elm/Request.hs b/src/Servant/Elm/Request.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Elm/Request.hs @@ -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 } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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)