diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for servant-flatten + +## 0.1 -- 2017-03-16 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Alp Mestanogullari + +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 Alp Mestanogullari 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +# servant-flatten + +Utilities for flattening servant API types + +The main function from this library is: + +``` haskell +flatten :: Proxy api -> Proxy (Flat api) +``` + +Its purpose is to "flatten" an API type, by distributing +any factored combinators, so as to end up with completely +flat endpoint descriptions, separated by `:<|>`s. + +For example, it turns: + +``` haskell +type API = Capture "foo" Int :> + ( Capture "bar" String :> + ( Get '[JSON] String :<|> + ReqBody '[JSON] Int :> Post '[JSON] Int + ) :<|> + Get '[JSON] Int + ) :<|> + Get '[JSON] [String] +``` + +into: + +``` haskell +Capture "foo" Int :> Capture "bar" String :> Get '[JSON] String :<|> +Capture "foo" Int :> Capture "bar" String :> ReqBody '[JSON] Int :> Post '[JSON] Int :<|> +Capture "foo" Int :> Get '[JSON] Int :<|> +Get '[JSON] [String] +``` + +See the documentation of `flatten` in `src/Servant/API/Flatten.hs` +for more explanations and some examples. 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-flatten.cabal b/servant-flatten.cabal new file mode 100644 --- /dev/null +++ b/servant-flatten.cabal @@ -0,0 +1,31 @@ +name: servant-flatten +version: 0.1 +synopsis: Utilities for flattening servant API types +description: Utilities for flattening servant API types + . + See the documentation of @'Servant.API.Flatten.flatten'@. +homepage: https://github.com/alpmestan/servant-flatten +bug-reports: http://github.com/alpmestan/servant-flatten/issues +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +copyright: 2018 Alp Mestanogullari, Julian Arni +category: Web +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 + +source-repository head + type: git + location: https://github.com/alpmestan/servant-flatten.git + +library + exposed-modules: Servant.API.Flatten + other-extensions: DataKinds, PolyKinds, TypeFamilies, TypeOperators, + FlexibleContexts, UndecidableInstances + build-depends: base >=4.8 && <5, servant >= 0.8 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Servant/API/Flatten.hs b/src/Servant/API/Flatten.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Flatten.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.API.Flatten where + +import Data.Proxy +import GHC.TypeLits +import Servant.API + +-- | Flatten (a 'Proxy' to) an API type. +-- +-- This performs a number of transformations on the API type so +-- as to end up with all combinators distributed over endpoints. +-- For example, the following API type: +-- +-- @ +-- type API = 'Capture' "foo" 'Int' ':>' +-- ( 'Capture' "bar" 'String' ':>' +-- ( 'Get' '['JSON'] 'String' ':<|>' +-- 'ReqBody' '['JSON'] 'Int' ':>' 'Post' '['JSON'] 'Int' +-- ) ':<|>' +-- 'Get' '['JSON'] 'Int' +-- ) ':<|>' +-- 'Get' '['JSON'] ['String'] +-- @ +-- +-- gets transformed into: +-- +-- @ +-- 'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'Get' '['JSON'] 'String' ':<|>' +-- 'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'ReqBody' '[JSON] 'Int' ':>' 'Post' '['JSON'] 'Int' ':<|>' +-- 'Capture' "foo" 'Int' ':>' 'Get' '['JSON'] 'Int' ':<|>' +-- 'Get' '['JSON'] ['String'] +-- @ +-- +-- The main point of doing this is to avoid \"nested types\" for server-side handlers +-- and client functions. See +-- (particularly the notes on @FactoringAPI@) for more about \"nested types\". +-- +-- To derive \"flat\" client functions for the API type above, @API@, you can do: +-- +-- @ +-- getfoobar ':<|>' postfoobar ':<|>' getfoo ':<|>' getstrings +-- = 'client' $ 'flatten' ('Proxy' :: 'Proxy' API) +-- @ +-- +-- To serve an implementation for that API with \"flat\" handler types, you can do: +-- +-- @ +-- -- we define all our handlers assuming all the arguments are distributed, +-- -- and declare that this is an implementation for @Flat API@, not @API@. +-- server :: Server ('Flat' API) +-- server = (\foo bar -> return $ show (foo + bar)) +-- ':<|>' (\foo bar body -> return $ show (foo + bar - body^2)) +-- ':<|>' (\foo -> return (foo * 2)) +-- ':<|>' (return ["hello", "world"]) +-- +-- api :: 'Proxy' API +-- api = 'Proxy' +-- +-- main :: 'IO' () +-- main = Network.Wai.Handler.Warp.run 8080 $ +-- serve ('flatten' api) server +-- @ +flatten :: Proxy api -> Proxy (Flat api) +flatten Proxy = Proxy + +-- | Flatten and transform the API type a little bit. +type Flat api = Reassoc (Flatten (Reassoc (Flatten api))) +-- looks like Flatten/Reassoc are missing some opportunities the first time, +-- so we apply them twice for now... + +-- | Completely flattens an API type by applying a few simple transformations. +-- The goal is to end up with an API type where things like @a ':>' (b ':<|>' c)@ +-- are rewritten to @a ':>' b ':<|>' a ':>' c@, so as to have client with very simple +-- types, instead of "nested clients". +type family Flatten (api :: k) :: k where + Flatten ((a :: k) :> (b :<|> c)) = Flatten (a :> b) :<|> Flatten (a :> c) + Flatten ((a :: k) :> b) = Redex b (Flatten b) a + Flatten (a :<|> b) = Flatten a :<|> Flatten b + Flatten (a :: k) = a + +type family Redex a b (c :: k) :: * where + Redex a a first = Flatten first :> a + Redex a b first = Flatten (first :> b) + +-- | Reassociates '(:<|>)' to the right. +type family Reassoc api where + Reassoc ((a :<|> b) :<|> c) = Reassoc a :<|> Reassoc (b :<|> c) + Reassoc (a :<|> b) = a :<|> Reassoc b + Reassoc a = a + +-- * Utilities that we can define on a flat representation + +-- | Get the endpoints with given indices in the all-flat +-- representation of the API type, glueing them together +-- with ':<|>'. +type family Nths (idxs :: [Nat]) api where + Nths '[i] api = Nth i api + Nths (i ': is) api = Nth i api :<|> Nths is api + +-- | Get the endpoint with given index in the all-flat representation +-- of the API type. +type family Nth (i :: Nat) api where + Nth 0 (a :<|> b) = a + Nth 0 a = a + Nth n (a :<|> b) = Nth (n - 1) b