diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -9,8 +9,8 @@ ## Features - Typed serialization/deserialization taken care of by Haskell's aeson and PureScript's argonaut. - Generic encoding/decoding of both made compatible by not yet merged - [pull request](https://github.com/purescript-contrib/purescript-argonaut-codecs/pull/12). + Generic encoding/decoding of both made compatible by + [purescript-argonaut-generic-codecs](https://github.com/eskimor/purescript-argonaut-generic-codecs/blob/purescript-argonaut-generic-codec/src/Data/Argonaut/Generic/Aeson.purs). - You can put common parameters like Auth tokens and the base URL in a reader monad so you don't have to pass them explicitly. This is configurable in the code generator with `readerParams` in `Settings`. diff --git a/servant-purescript.cabal b/servant-purescript.cabal --- a/servant-purescript.cabal +++ b/servant-purescript.cabal @@ -1,5 +1,5 @@ name: servant-purescript -version: 0.1.0.2 +version: 0.2.0.0 synopsis: Generate PureScript accessor functions for you servant API description: Please see README.md homepage: https://github.com/eskimor/servant-purescript#readme @@ -20,10 +20,12 @@ exposed-modules: Servant.PureScript.Internal , Servant.PureScript.CodeGen , Servant.PureScript + , Servant.API.BrowserHeader -- other-modules: Main build-depends: base >= 4.7 && < 5 , aeson >= 0.11.2 + , bytestring , containers , directory , filepath @@ -33,6 +35,7 @@ , purescript-bridge >= 0.6 && < 0.7 , servant , servant-foreign + , servant-server , servant-subscriber , text default-language: Haskell2010 diff --git a/src/Servant/API/BrowserHeader.hs b/src/Servant/API/BrowserHeader.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/BrowserHeader.hs @@ -0,0 +1,46 @@ +-- | A header which gets sent by the browser and is thus of no concern for the client consumer of the API. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.API.BrowserHeader where + +import Servant.Utils.Links +import Servant +import Servant.Foreign +import Servant.Subscriber.Subscribable +import GHC.TypeLits + +data BrowserHeader (sym :: Symbol) a + + + +type instance IsElem' e (BrowserHeader :> s) = IsElem e s + +instance HasLink sub => HasLink (BrowserHeader sym a :> sub) where + type MkLink (BrowserHeader sym a :> sub) = MkLink (Header sym a :> sub) + toLink _ = toLink (Proxy :: Proxy (Header sym a :> sub)) + +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (BrowserHeader sym a :> sublayout) context where + + type ServerT (BrowserHeader sym a :> sublayout) m = ServerT (Header sym a :> sublayout) m + + route Proxy = route (Proxy :: Proxy (Header sym a :> sublayout)) + + +-- Ignore BrowserHeader in HasForeign: +instance (KnownSymbol sym, HasForeign lang ftype sublayout) + => HasForeign lang ftype (BrowserHeader sym a :> sublayout) where + type Foreign ftype (BrowserHeader sym a :> sublayout) = Foreign ftype sublayout + + foreignFor lang p Proxy = foreignFor lang p (Proxy :: Proxy sublayout) + +type instance IsSubscribable' endpoint (BrowserHeader sym a :> sub ) = IsSubscribable endpoint sub diff --git a/src/Servant/PureScript.hs b/src/Servant/PureScript.hs --- a/src/Servant/PureScript.hs +++ b/src/Servant/PureScript.hs @@ -20,36 +20,31 @@ , standardImports , defaultSettings , addReaderParam +, jsonParseUrlPiece +, jsonToUrlPiece +, jsonParseHeader +, jsonToHeader ) where -import Control.Lens + import Data.Aeson import Data.Bifunctor -import Data.Char -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe, maybeToList) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BS import Data.Monoid import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable -import GHC.Generics hiding (to) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Language.PureScript.Bridge -import Language.PureScript.Bridge.Printer -import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo -import Servant.API +import Network.HTTP.Types (urlDecode, urlEncode) import Servant.Foreign import Servant.PureScript.CodeGen import Servant.PureScript.Internal import System.Directory import System.FilePath -import System.IO (IOMode (..), withFile) -import Text.PrettyPrint.Mainland (hPutDocLn) +import System.IO (IOMode (..), withFile) +import Text.PrettyPrint.Mainland (hPutDocLn) writeAPIModule :: forall bridgeSelector api. ( HasForeign (PureScript bridgeSelector) PSType api @@ -72,3 +67,35 @@ mFile = (joinPath . map T.unpack . T.splitOn "." $ _apiModuleName opts) <> ".purs" mPath = root mFile mDir = takeDirectory mPath + + +-- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances +-- in order to be compatible with the generated PS code. +-- +-- > +-- > instance ToHttpApiData MyDataType where +-- > toUrlPiece = jsonToUrlPiece +-- > toHeader = jsonToHeader +-- > +-- > instance FromHttpApiData MyDataType where +-- > parseUrlPiece = jsonParseUrlPiece +-- > parseHeader = jsonParseHeader +-- > +-- +jsonParseUrlPiece :: FromJSON a => Text -> Either Text a +jsonParseUrlPiece = first T.pack . eitherDecodeStrict . T.encodeUtf8 + +-- | Use this function for implementing 'toUrlPiece' in your ToHttpApiData instances +-- in order to be compatible with the generated PS code. +jsonToUrlPiece :: ToJSON a => a -> Text +jsonToUrlPiece = T.decodeUtf8 . jsonToHeader + +-- | Use this function for implementing 'parseHeader' in your FromHttpApiData instances +-- in order to be compatible with the generated PS code. +jsonParseHeader :: FromJSON a => ByteString -> Either Text a +jsonParseHeader = first T.pack . eitherDecodeStrict . urlDecode True + +-- | Use this function for implementing 'toHeader' in your ToHttpApiData instances +-- in order to be compatible with the generated PS code. +jsonToHeader :: ToJSON a => a -> ByteString +jsonToHeader = urlEncode True . BS.toStrict . encode diff --git a/src/Servant/PureScript/CodeGen.hs b/src/Servant/PureScript/CodeGen.hs --- a/src/Servant/PureScript/CodeGen.hs +++ b/src/Servant/PureScript/CodeGen.hs @@ -8,30 +8,18 @@ module Servant.PureScript.CodeGen where -import Servant.PureScript.Internal -import Text.PrettyPrint.Mainland - -import Control.Lens hiding (List) -import Data.Aeson -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe, maybeToList) -import Data.Monoid -import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable -import GHC.Generics hiding (to) +import Control.Lens hiding (List) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe, maybeToList) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text.Encoding as T import Language.PureScript.Bridge -import Language.PureScript.Bridge.Printer -import Language.PureScript.Bridge.PSTypes (psString) -import Language.PureScript.Bridge.TypeInfo -import Network.HTTP.Types.URI (urlEncode) -import Servant.API +import Language.PureScript.Bridge.PSTypes (psString) +import Network.HTTP.Types.URI (urlEncode) import Servant.Foreign +import Servant.PureScript.Internal +import Text.PrettyPrint.Mainland genModule :: Settings -> [Req PSType] -> Doc genModule opts reqs = let @@ -91,7 +79,7 @@ genGetReaderParams :: [PSParam] -> Doc genGetReaderParams = stack . map (genGetReaderParam . psVar . _pName) where - genGetReaderParam pName = "let" <+> pName <+> "= spParams_." <> pName + genGetReaderParam pName' = "let" <+> pName' <+> "= spParams_." <> pName' genSignature :: Text -> [PSType] -> Maybe PSType -> Doc @@ -99,7 +87,7 @@ where fName = strictText fnName constraint = ":: forall eff m." <+/> "(MonadReader (SPSettings_ SPParams_) m, MonadError AjaxError m, MonadAff ( ajax :: AJAX | eff) m)" <+/> "=>" - retName = maybe "Unit" (strictText . typeInfoToText True) mRet + retName = maybe "Unit" (strictText . typeInfoToText False) mRet retString = "m" <+> retName typeNames = map (strictText . typeInfoToText True) params parameterString = docIntercalate (softline <> "-> ") (typeNames <> [retString]) @@ -113,7 +101,8 @@ genFnBody :: [PSParam] -> Req PSType -> Doc genFnBody rParams req = "do" indent 2 ( - "SPSettings_ spOpts_ <- ask" + "spOpts_' <- ask" + "let spOpts_ = case spOpts_' of SPSettings_ o -> o" "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_" genGetReaderParams rParams hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText)) @@ -125,9 +114,9 @@ ", headers =" <+> "defaultRequest.headers <> reqHeaders" case req ^. reqBody of Nothing -> "}" - Just _ -> ", content =" <+> "toNullable <<< Just <<< printJson <<< gAesonEncodeJson $ reqBody" "}" + Just _ -> ", content =" <+> "toNullable <<< Just <<< printJson <<< encodeJson $ reqBody" "}" ) - "getResult gAesonDecodeJson affResp" <> line + "getResult decodeJson affResp" <> line ) genBuildURL :: Url PSType -> Doc @@ -140,7 +129,7 @@ genBuildSegment :: SegmentType PSType -> Doc genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText (textURLEncode False seg) -genBuildSegment (Cap arg) = parens $ "encodeURIComponent" <+> arg ^. argName ^. to unPathSegment ^. to psVar +genBuildSegment (Cap arg) = "encodeURLPiece spOpts_'" <+> arg ^. argName ^. to unPathSegment ^. to psVar ---------- genBuildQuery :: [QueryArg PSType] -> Doc @@ -169,7 +158,7 @@ in align $ "{ field : " <> dquotes encodedArgName <+/> comma <+> "value :" - <+> "(encodeURIComponent <<< gDefaultToURLPiece)" <+> psVar argText + <+> "encodeURLPiece spOpts_'" <+> psVar argText "}" genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!" diff --git a/src/Servant/PureScript/Internal.hs b/src/Servant/PureScript/Internal.hs --- a/src/Servant/PureScript/Internal.hs +++ b/src/Servant/PureScript/Internal.hs @@ -12,26 +12,21 @@ module Servant.PureScript.Internal where import Control.Lens -import Data.Aeson + import Data.Bifunctor import Data.Char -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe, maybeToList) import Data.Monoid import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Typeable -import GHC.Generics hiding (to) + import Language.PureScript.Bridge -import Language.PureScript.Bridge.Printer import Language.PureScript.Bridge.PSTypes -import Language.PureScript.Bridge.TypeInfo -import Servant.API + + import Servant.Foreign @@ -48,7 +43,7 @@ -- data PureScript bridgeSelector -instance (Generic a, Typeable a, HasBridge bridgeSelector) => HasForeignType (PureScript bridgeSelector) PSType a where +instance (Typeable a, HasBridge bridgeSelector) => HasForeignType (PureScript bridgeSelector) PSType a where typeFor _ _ _ = languageBridge (Proxy :: Proxy bridgeSelector) (mkTypeInfo (Proxy :: Proxy a)) class HasBridge a where @@ -104,9 +99,9 @@ , ImportLine "Data.Nullable" (Set.fromList [ "Nullable()", "toNullable" ]) , ImportLine "Servant.PureScript.Affjax" (Set.fromList [ "defaultRequest", "affjax", "AjaxError(..)" ]) , ImportLine "Servant.PureScript.Settings" (Set.fromList [ "SPSettings_(..)", "gDefaultToURLPiece" ]) - , ImportLine "Servant.PureScript.Util" (Set.fromList [ "encodeListQuery", "encodeQueryItem", "getResult" ]) + , ImportLine "Servant.PureScript.Util" (Set.fromList [ "encodeListQuery", "encodeURLPiece", "encodeQueryItem", "getResult" ]) , ImportLine "Prim" (Set.fromList [ "String" ]) -- For baseURL! - , ImportLine "Data.Argonaut.Aeson" (Set.fromList [ "gAesonEncodeJson", "gAesonDecodeJson" ]) -- Should not be necessary - compiler bug! + , ImportLine "Data.Argonaut.Generic.Aeson" (Set.fromList [ "encodeJson", "decodeJson" ]) -- Should not be necessary - compiler bug! , ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"]) , ImportLine "Data.Argonaut.Printer" (Set.fromList [ "printJson" ]) ]