diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni 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-auth-docs.cabal b/servant-auth-docs.cabal new file mode 100644 --- /dev/null +++ b/servant-auth-docs.cabal @@ -0,0 +1,79 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: servant-auth-docs +version: 0.1.0.0 +description: Please see README.md +homepage: http://github.com/jkarni/servant-auth-docs#readme +bug-reports: https://github.com/jkarni/servant-auth-docs/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.10.2, GHC == 8.0.1 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/jkarni/servant-auth-docs + +library + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + , servant-docs + , servant + , servant-auth + , lens + exposed-modules: + Servant.Auth.Docs + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + , servant-docs + , servant + , servant-auth + , lens + , doctest >= 0.9 && < 0.12 + , Glob >= 0.7 && < 0.8 + , yaml == 0.8.* + other-modules: + Spec + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: AutoDeriveTypeable ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.10 + , text + , servant-docs + , servant + , servant-auth + , lens + , servant-auth-docs + , hspec > 2 && < 3 + , QuickCheck >= 2.8 && < 2.9 + other-modules: + Doctest + default-language: Haskell2010 diff --git a/src/Servant/Auth/Docs.hs b/src/Servant/Auth/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Auth/Docs.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Auth.Docs + ( + -- | The purpose of this package is provide the instance for 'servant-auth' + -- combinators needed for 'servant-docs' documentation generation. + -- + -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int + -- >>> putStr $ markdown $ docs (Proxy :: Proxy API) + -- ## GET / + -- ... + -- #### Authentication + -- ... + -- This part of the API is protected by the following authentication mechanisms: + -- ... + -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token)) + -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie) + -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication) + -- ... + -- ... + -- Clients must supply the following data + -- ... + -- One of the following: + -- ... + -- * A JWT Token signed with this server's key + -- * Cookies automatically set by browsers, plus a header + -- * Cookies automatically set by browsers, plus a header + -- ... + + -- * Re-export + JWT + , BasicAuth + , Cookie + , Auth + ) where + +import Control.Lens ((%~), (&), (|>)) +import Data.List (intercalate) +import Data.Monoid +import Data.Proxy (Proxy (Proxy)) +import Servant.API hiding (BasicAuth) +import Servant.Auth +import Servant.Docs hiding (pretty) +import Servant.Docs.Internal (DocAuthentication (..), authInfo) + +instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where + docsFor _ (endpoint, action) = + docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info)) + where + (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths) + info = DocAuthentication intro reqData + + +pretty :: [(String, String)] -> (String, String) +pretty [] = error "shouldn't happen" +pretty [(i, d)] = + ( "This part of the API is protected by " <> i + , d + ) +pretty rs = + ( "This part of the API is protected by the following authentication mechanisms:\n\n" + ++ " * " <> intercalate "\n * " (fst <$> rs) + , "\nOne of the following:\n\n" + ++ " * " <> intercalate "\n * " (snd <$> rs) + ) + + +class AllDocs (x :: [*]) where + allDocs :: proxy x + -- intro, req + -> [(String, String)] + +instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where + allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as) + +instance AllDocs '[] where + allDocs _ = [] + +class OneDoc a where + oneDoc :: proxy a -> (String, String) + +instance OneDoc JWT where + oneDoc _ = + ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))" + , "A JWT Token signed with this server's key") + +instance OneDoc Cookie where + oneDoc _ = + ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)" + , "Cookies automatically set by browsers, plus a header") + +instance OneDoc BasicAuth where + oneDoc _ = + ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)" + , "Cookies automatically set by browsers, plus a header") + +-- $setup +-- >>> instance ToSample Int where toSamples _ = singleSample 1729 diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,26 @@ +module Main (main) where + +-- Runs doctest on all files in "src" dir. Assumes: +-- (a) You are using hpack +-- (b) The top-level "default-extensions" are the only extensions besides the +-- ones in the files. + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) +import Data.Yaml + +newtype Exts = Exts { getExts :: [String] } + deriving (Eq, Show, Read) + +instance FromJSON Exts where + parseJSON (Object v) = Exts <$> v .: "default-extensions" + parseJSON _ = fail "expecting object" + +main :: IO () +main = do + hpack' <- decodeFile "package.yaml" + hpack <- case hpack' of + Nothing -> return $ Exts [] + Just v -> return v + files <- glob "src/**/*.hs" + doctest $ files ++ fmap ("-X" ++) (getExts hpack) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}