haskell-admin-core (empty) → 1.0.0.0

raw patch · 18 files changed

+507/−0 lines, 18 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, haskell-admin-core, hspec, hspec-wai, http-types, servant, servant-server, wai, wai-cors, wai-extra, wai-middleware-bearer, word8

Files

• ChangeLog.md +3/−0
• LICENSE +20/−0
• README.md +3/−0
• Setup.hs +3/−0
• haskell-admin-core.cabal +83/−0
• src/Admin/API.hs +25/−0
• src/Admin/Component/EmptyComponent.hs +12/−0
• src/Admin/Components.hs +9/−0
• src/Admin/Components/Component.hs +22/−0
• src/Admin/Components/ComponentDescription.hs +16/−0
• src/Admin/Components/ComponentList.hs +37/−0
• src/Admin/Components/ComponentsClass.hs +66/−0
• src/Admin/Components/Internal/TypeLevel.hs +48/−0
• src/Admin/Server.hs +41/−0
• src/Admin/Server/Middlewares.hs +22/−0
• test/Spec.hs +16/−0
• test/Spec/Admin/Components.hs +35/−0
• test/Spec/Admin/Server.hs +46/−0

@@ -0,0 +1,3 @@+# Changelog for haskell-admin-core++## Unreleased changes

@@ -0,0 +1,20 @@+Copyright (c) 2022 Martin Bednar++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,3 @@+# haskell-admin-core++This package provides the core implementation of Haskell Admin without any components. It can be used to develop new components.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

@@ -0,0 +1,83 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           haskell-admin-core+version:        1.0.0.0+synopsis:       Core Modules of Haskell Admin+description:    Please see the README on GitHub at <https://github.com/martin-bednar/haskell-admin#readme>+category:       Remote Management, Web+homepage:       https://github.com/martin-bednar/haskell-admin#readme+bug-reports:    https://github.com/martin-bednar/haskell-admin/issues+author:         Martin Bednar+maintainer:     bednam17@fit.cvut.cz+copyright:      2022 Martin Bednar+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/martin-bednar/haskell-admin++library+  exposed-modules:+      Admin.API+      Admin.Component.EmptyComponent+      Admin.Components+      Admin.Components.Component+      Admin.Components.ComponentDescription+      Admin.Components.ComponentList+      Admin.Components.ComponentsClass+      Admin.Components.Internal.TypeLevel+      Admin.Server+      Admin.Server.Middlewares+  other-modules:+      Paths_haskell_admin_core+  hs-source-dirs:+      src+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Wmonomorphism-restriction -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , http-types+    , servant+    , servant-server+    , wai+    , wai-cors+    , wai-middleware-bearer+    , word8+  default-language: Haskell2010++test-suite haskell-admin-core-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Spec.Admin.Components+      Spec.Admin.Server+      Paths_haskell_admin_core+  hs-source-dirs:+      test+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Wmonomorphism-restriction -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring+    , haskell-admin-core+    , hspec+    , hspec-wai+    , http-types+    , servant+    , servant-server+    , wai+    , wai-cors+    , wai-extra+    , wai-middleware-bearer+    , word8+  default-language: Haskell2010

@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE PolyKinds #-}++module Admin.API+  ( AdminAPI+  , ComponentsAPI+  ) where++import Admin.Components.ComponentDescription (ComponentDescription)+import Data.Version+import Servant++-- | The type-level definition of the Haskell Admin API+-- with server components as a parameter+type AdminAPI components = Root :<|> "components" :> ComponentsAPI components++type Root = Get '[ JSON] NoContent :<|> "api_version" :> Get '[ JSON] Version++type ComponentsAPI inner = Get '[ JSON] [ComponentDescription] :<|> inner

@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds #-}++module Admin.Component.EmptyComponent+  ( emptyComponent+  ) where++import Admin.Components+import Data.Version (makeVersion)+import Servant++emptyComponent :: Component "empty" EmptyAPI+emptyComponent = Component {server = emptyServer, version = makeVersion [1]}

@@ -0,0 +1,9 @@+module Admin.Components+  ( module Admin.Components.Component+  , module Admin.Components.ComponentList+  , module Admin.Components.ComponentsClass+  ) where++import Admin.Components.Component+import Admin.Components.ComponentList+import Admin.Components.ComponentsClass

@@ -0,0 +1,22 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Admin.Components.Component+  ( Component(..)+  ) where++import Data.Version+import GHC.TypeLits (Symbol)+import Servant++data Component (name :: Symbol) api =+  Component+    { server :: Server api+    , version :: Version+    }

@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ExplicitForAll #-}++module Admin.Components.ComponentDescription where++import Data.Aeson (FromJSON, ToJSON)+import Data.Version (Version)+import GHC.Generics (Generic)++data ComponentDescription =+  ComponentDescription+    { componentName :: String+    , componentVersion :: Version+    }+  deriving (Read, Show, Eq, Generic, ToJSON, FromJSON)

@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Admin.Components.ComponentList+  ( ComponentList(..)+  , namesOf+  , descriptionsOf+  , empty+  ) where++import Admin.Components.ComponentDescription+import Admin.Components.Internal.TypeLevel (ManySymbolVal, manySymbolVal)+import Data.Version+import GHC.TypeLits (Symbol)+import Servant++data ComponentList (names :: [Symbol]) apis =+  ComponentList+    { serveAll :: Server apis+    , versions :: [Version]+    }++namesOf ::+     forall names apis. (ManySymbolVal names)+  => ComponentList names apis+  -> [String]+namesOf _ = manySymbolVal (Proxy :: Proxy names)++descriptionsOf ::+     forall names apis. (ManySymbolVal names)+  => ComponentList names apis+  -> [ComponentDescription]+descriptionsOf cs = zipWith ComponentDescription (namesOf cs) (versions cs)++empty :: ComponentList '[] EmptyAPI+empty = ComponentList emptyServer [makeVersion [1]]

@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Admin.Components.ComponentsClass+  ( with+  , Components(..)+  ) where++import Admin.Components.Component+import Admin.Components.ComponentDescription+import Admin.Components.ComponentList+import Admin.Components.Internal.TypeLevel+import Data.Version+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Servant++type ToServantAPI names api = (ManySymbolVal names, HasServer api '[])++class (ToServantAPI names apis) =>+      Components a (names :: [Symbol]) apis+  | a -> names apis+  where+  serveAll' :: a -> Server apis+  describe :: a -> [ComponentDescription]++instance (KnownSymbol name, HasServer api '[]) =>+         Components (Component name api) '[ name] (name :> api) where+  serveAll' c = server c+  describe c =+    let n = symbolVal (Proxy :: Proxy name)+        v = version c+     in [ComponentDescription n v]++instance (ToServantAPI names apis) =>+         Components (ComponentList names apis) names apis where+  serveAll' c = serveAll c+  describe c = descriptionsOf c++getVersions :: Components a names apis => a -> [Version]+getVersions = map componentVersion . describe++infixr 9 `with`++-- | Compose Components+--+-- This function combines a 'Component' with another 'Component',+-- or with a 'ComponentList', producing a 'ComponentList'.+--+-- It collects the names of the components,+-- and keeps the expected API structure.+--+-- Usage:+-- >>> componentA `with` componentB `with` componentC+with ::+     (Components a names apis)+  => Component name api+  -> a+  -> ComponentList (name : names) ((name :> api) :<|> apis)+with new lst =+  ComponentList (server new :<|> serveAll' lst) (version new : getVersions lst)

@@ -0,0 +1,48 @@+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}++module Admin.Components.Internal.TypeLevel+  ( NamesOf+  , NameOf+  , ApisOf+  , ApiOf+  , ManySymbolVal(..)+  ) where++import Admin.Components.Component (Component(..))+import Data.Data (Proxy(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Servant.API ((:<|>), (:>))++type family NameOf (x :: *) where+  NameOf (Component name api) = (name :: Symbol)++type family ApiOf (x :: *) where+  ApiOf (Component (name :: Symbol) api) = name :> api++type family NamesOf (xs :: [*]) where+  NamesOf '[] = '[]+  NamesOf (x ': xs) = NameOf x ': NamesOf xs++type family ApisOf (xs :: [*]) where+  ApisOf (x ': '[]) = ApiOf x+  ApisOf (x ': xs) = ApiOf x :<|> ApisOf xs++-- Type class ManySymbolVal+-- Source: https://stackoverflow.com/a/37365020+-- Author: Andrew Thaddeus Martin+class ManySymbolVal (xs :: [Symbol]) where+  manySymbolVal :: proxy xs -> [String]++instance ManySymbolVal '[] where+  manySymbolVal _ = []++instance (KnownSymbol a, ManySymbolVal as) => ManySymbolVal (a ': as) where+  manySymbolVal _ =+    symbolVal (Proxy :: Proxy a) : manySymbolVal (Proxy :: Proxy as)

@@ -0,0 +1,41 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}++module Admin.Server+  ( adminApp+  , serveAdmin+  ) where++import Admin.API+import Admin.Components+import Admin.Server.Middlewares (middlewares)+import Data.ByteString.Char8 (ByteString)+import Data.Version+import Servant++adminApp :: Components a names api => a -> [ByteString] -> Application+adminApp c =+  let p = (Proxy :: Proxy (AdminAPI api))+   in adminApp' c p++adminApp' ::+     Components a names api+  => a+  -> Proxy (AdminAPI api)+  -> [ByteString]+  -> Application+adminApp' c proxy tokens = withMiddlewares tokens $ serve proxy $ serveAdmin c++withMiddlewares :: [ByteString] -> Application -> Application+withMiddlewares = middlewares++serveAdmin :: Components a names api => a -> Server (AdminAPI api)+serveAdmin c = handleRoot :<|> serveComponents c++serveComponents :: Components a names apis => a -> Server (ComponentsAPI apis)+serveComponents c = return (describe c) :<|> serveAll' c++handleRoot = return NoContent :<|> return (makeVersion [1])

@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}++module Admin.Server.Middlewares+  ( middlewares+  ) where++import Data.ByteString.Char8 (ByteString)+import Network.Wai (Middleware)+import Network.Wai.Middleware.BearerTokenAuth+import Network.Wai.Middleware.Cors++-- | Middlewares used in Haskell Admin+middlewares :: [ByteString] -> Middleware+middlewares tokens = allowCors . tokenListAuth tokens++allowCors :: Middleware+allowCors = cors (const $ Just policy)++policy :: CorsResourcePolicy+policy =+  simpleCorsResourcePolicy+    {corsRequestHeaders = ["Authorization", "Content-Type"]}

@@ -0,0 +1,16 @@+module Main+  ( main+  ) where++import Test.Hspec++import qualified Spec.Admin.Components+import qualified Spec.Admin.Server++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "Spec.Admin.Components" Spec.Admin.Components.spec+  describe "Spec.Admin.Server" Spec.Admin.Server.spec

@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}++module Spec.Admin.Components+  ( spec+  ) where++import Admin.Components+import Test.Hspec as Hspec++import Admin.Components.ComponentDescription+  ( ComponentDescription(ComponentDescription)+  )+import Data.Version (makeVersion)+import Servant++components = cA `with` cB++cA :: Component "Comp. A" EmptyAPI+cA = Component {server = emptyServer, version = makeVersion [1]}++cB :: Component "Comp. B" EmptyAPI+cB = Component {server = emptyServer, version = makeVersion [2, 4]}++spec :: Spec+spec = do+  Hspec.describe "Admin.Components.ComponentList" $ do+    Hspec.describe "namesOf" $ do+      it "returns names of all components" $ do+        namesOf components `shouldBe` ["Comp. A", "Comp. B"]+    Hspec.describe "descriptionsOf" $ do+      it "returns descriptions of all components" $ do+        descriptionsOf components `shouldBe`+          [ ComponentDescription "Comp. A" (makeVersion [1])+          , ComponentDescription "Comp. B" (makeVersion [2, 4])+          ]

@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.Admin.Server+  ( spec+  ) where++import Admin.Component.EmptyComponent+import Admin.Server+import Data.ByteString+import Network.HTTP.Types.Header+import Network.HTTP.Types.Method+import Network.Wai.Test (SResponse)+import Servant (Application)+import Test.Hspec+import Test.Hspec.Wai++app :: IO Application+app = return $ adminApp emptyComponent ["testApiKey"]++authHeader :: Header+authHeader = ("Authorization", "Bearer testApiKey")++getS :: ByteString -> WaiSession st SResponse+getS path = request methodGet path [authHeader] ""++spec :: Spec+spec =+  with app $ do+    describe "GET /" $ do+      it "responds to the root path" $ do getS "/" `shouldRespondWith` 200+    describe "GET /api_version" $ do+      it "responds with the API version" $ do+        getS "/api_version" `shouldRespondWith` 200 {matchBody = "\"1\""}+    describe "GET /components" $ do+      it "lists components" $ do+        getS "/components" `shouldRespondWith`+          200+            { matchBody =+                "[{\"componentName\":\"empty\",\"componentVersion\":\"1\"}]"+            }+    describe "authorization" $ do+      it "refuses unauthorized requests" $ do+        get "/" `shouldRespondWith` 401+        request methodGet "/" [("Authorization", "Bearer badKey")] "" `shouldRespondWith`+          401