Third pass, now with fourmolu-0.18.0.0

Author: zlondrej

.github/workflows/code-style.yaml

@@ -0,0 +1,25 @@
+name: Code style check
+
+concurrency:
+  group: formatting-${{ github.ref_name }}
+  cancel-in-progress: true
+
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+  workflow_dispatch: {}
+
+jobs:
+  formatting:
+    steps:
+      - name: Checkout Code
+        uses: actions/checkout@v4
+        with:
+          fetch-depth: 1
+      - name: Install Nix
+        uses: cachix/install-nix-action@v31
+      - name: Check code formatting
+        run: |
+          nix develop '#formatters' --command fourmolu --mode=check --check-idempotence servant servant-*

CONTRIBUTING.md

@@ -35,8 +35,9 @@ Some things we like:
 - Few dependencies
 - -Werror-compatible (7.8, 7.10 and 8.0)
 
-Though we aren't sticklers for style, the `fourmolu.yaml` and `HLint.hs` files in the repository provide a good baseline for consistency.
-For nix, `nixfmt-rfc-style` is preferred.
+Haskell code should be formatted with `fourmolu` (`>= 0.18.0.0`).
+Please try to avoid introducing new `hlint` warnings.
+For Nix files, `nixfmt-rfc-style` is preferred.
 
 **Important**: please do not modify the versions of the servant packages you are sending patches for.
 

flake.nix

@@ -17,6 +17,14 @@
       let
         pkgs = import nixpkgs { inherit system; };
 
+        format-tools = [
+          # We use fourmolu compiled with GHC 9.12
+          # as getting it to compile with lower GHC versions
+          # is complicated and this works out of the box.
+          pkgs.haskell.packages.ghc912.fourmolu_0_18_0_0
+          pkgs.nixfmt-rfc-style
+        ];
+
         mkDevShell =
           {
             compiler ? "ghc92",
@@ -44,10 +52,9 @@
                 postgresql
                 openssl
                 stack
-                fourmolu
-                nixfmt-rfc-style
                 haskellPackages.hspec-discover
               ]
+              ++ format-tools
               ++ (
                 if tutorial then
                   [
@@ -68,6 +75,9 @@
         devShells = {
           default = mkDevShell { };
           tutorial = mkDevShell { tutorial = true; };
+          formatters = pkgs.mkShell {
+            buildInputs = format-tools;
+          };
         };
       }
     );

servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs

@@ -20,7 +20,7 @@ import Servant.Client.Core
 
 -- | A simple bearer token.
 newtype Token = Token {getToken :: BS.ByteString}
-  deriving (Eq, Show, Read, Generic, IsString)
+  deriving (Eq, Generic, IsString, Read, Show)
 
 type family HasBearer xs :: Constraint where
   HasBearer (Bearer ': xs) = ()

servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs

@@ -42,10 +42,11 @@ import Control.Monad.Trans.Except (runExceptT)
 #define ClientError ServantError
 #endif
 
-import Servant.Auth.Client
 import Servant.Auth.Server
 import Servant.Auth.Server.SetCookieOrphan ()
 
+import Servant.Auth.Client
+
 spec :: Spec
 spec = describe "The JWT combinator" $ do
   hasClientSpec
@@ -152,7 +153,7 @@ data User = User
   { name :: String
   , _id :: String
   }
-  deriving (Eq, Show, Read, Generic)
+  deriving (Eq, Generic, Read, Show)
 
 instance FromJWT User
 

servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs

@@ -69,7 +69,7 @@ class AllDocs (x :: [Type]) where
     -- intro, req
     -> [(String, String)]
 
-instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where
+instance (AllDocs as, OneDoc a) => AllDocs (a ': as) where
   allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as)
 
 instance AllDocs '[] where

servant-auth/servant-auth-server/src/Servant/Auth/Server.hs

@@ -151,6 +151,9 @@ import Data.Default (Default (def))
 import Servant (BasicAuthData (..))
 import Servant.Auth
 import Servant.Auth.JWT
+import Web.Cookie (SetCookie)
+import Prelude hiding (readFile, writeFile)
+
 import Servant.Auth.Server.Internal ()
 import Servant.Auth.Server.Internal.BasicAuth
 import Servant.Auth.Server.Internal.Class
@@ -159,8 +162,6 @@ import Servant.Auth.Server.Internal.Cookie
 import Servant.Auth.Server.Internal.JWT
 import Servant.Auth.Server.Internal.ThrowAll
 import Servant.Auth.Server.Internal.Types
-import Web.Cookie (SetCookie)
-import Prelude hiding (readFile, writeFile)
 
 -- | Generate a key suitable for use with 'defaultConfig'.
 generateKey :: IO Jose.JWK

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs

@@ -14,61 +14,63 @@ import Servant
   )
 import Servant.Auth
 import Servant.Auth.JWT (ToJWT)
+import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
+
 import Servant.Auth.Server.Internal.AddSetCookie
 import Servant.Auth.Server.Internal.Class
 import Servant.Auth.Server.Internal.ConfigTypes
 import Servant.Auth.Server.Internal.Cookie
 import Servant.Auth.Server.Internal.JWT
 import Servant.Auth.Server.Internal.Types
-import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
 
 instance
-  ( n ~ 'S ('S 'Z)
-  , HasServer (AddSetCookiesApi n api) ctxs
+  ( -- this constraint is needed to implement hoistServer
+    AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
   , AreAuths auths ctxs v
-  , HasServer api ctxs -- this constraint is needed to implement hoistServer
-  , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
-  , ToJWT v
   , HasContextEntry ctxs CookieSettings
   , HasContextEntry ctxs JWTSettings
+  , HasServer (AddSetCookiesApi n api) ctxs
+  , HasServer api ctxs
+  , ToJWT v
+  , n ~ 'S ('S 'Z)
   )
   => HasServer (Auth auths v :> api) ctxs
   where
   type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m
 
-#if MIN_VERSION_servant_server(0,12,0)
-  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
-#endif
+  route _ context subserver =
+    route
+      (Proxy :: Proxy (AddSetCookiesApi n api))
+      context
+      (fmap go subserver `addAuthCheck` authCheck)
+    where
+      authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
+      authCheck = withRequest $ \req -> liftIO $ do
+        authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
+        cookies <- makeCookies authResult
+        return (authResult, cookies)
 
-route _ context subserver =
-  route
-    (Proxy :: Proxy (AddSetCookiesApi n api))
-    context
-    (fmap go subserver `addAuthCheck` authCheck)
-  where
-    authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
-    authCheck = withRequest $ \req -> liftIO $ do
-      authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
-      cookies <- makeCookies authResult
-      return (authResult, cookies)
+      jwtSettings :: JWTSettings
+      jwtSettings = getContextEntry context
 
-    jwtSettings :: JWTSettings
-    jwtSettings = getContextEntry context
+      cookieSettings :: CookieSettings
+      cookieSettings = getContextEntry context
 
-    cookieSettings :: CookieSettings
-    cookieSettings = getContextEntry context
+      makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
+      makeCookies authResult = do
+        case authResult of
+          (Authenticated v) -> do
+            ejwt <- makeSessionCookie cookieSettings jwtSettings v
+            xsrf <- makeXsrfCookie cookieSettings
+            return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
+          _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
 
-    makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
-    makeCookies authResult = do
-      case authResult of
-        (Authenticated v) -> do
-          ejwt <- makeSessionCookie cookieSettings jwtSettings v
-          xsrf <- makeXsrfCookie cookieSettings
-          return $ Just xsrf `SetCookieCons` (ejwt `SetCookieCons` SetCookieNil)
-        _ -> return $ Nothing `SetCookieCons` (Nothing `SetCookieCons` SetCookieNil)
+      go
+        :: (AuthResult v -> ServerT api Handler)
+        -> (AuthResult v, SetCookieList n)
+        -> ServerT (AddSetCookiesApi n api) Handler
+      go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
 
-    go
-      :: (AuthResult v -> ServerT api Handler)
-      -> (AuthResult v, SetCookieList n)
-      -> ServerT (AddSetCookiesApi n api) Handler
-    go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
+#if MIN_VERSION_servant_server(0,12,0)
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
+#endif

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs

@@ -80,9 +80,9 @@ instance orig1 ~ orig2 => AddSetCookies 'Z orig1 orig2 where
 
 instance
   {-# OVERLAPPABLE #-}
-  ( Functor m
+  ( AddHeader mods "Set-Cookie" SetCookie cookied new
   , AddSetCookies n (m old) (m cookied)
-  , AddHeader mods "Set-Cookie" SetCookie cookied new
+  , Functor m
   )
   => AddSetCookies ('S n) (m old) (m new)
   where
@@ -108,8 +108,8 @@ instance
 instance
   {-# OVERLAPS #-}
   ( AddSetCookies ('S n) (ServerT (ToServantApi api) m) cookiedApi
-  , Generic (api (AsServerT m))
   , GServantProduct (Rep (api (AsServerT m)))
+  , Generic (api (AsServerT m))
   , ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
   )
   => AddSetCookies ('S n) (api (AsServerT m)) cookiedApi

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs

@@ -8,9 +8,10 @@ module Servant.Auth.Server.Internal.BasicAuth where
 
 import qualified Data.ByteString as BS
 import Servant (BasicAuthData (..), ServerError (..), err401)
-import Servant.Auth.Server.Internal.Types
 import Servant.Server.Internal.BasicAuth (decodeBAHdr, mkBAChallengerHdr)
 
+import Servant.Auth.Server.Internal.Types
+
 -- | A 'ServerError' that asks the client to authenticate via Basic
 -- Authentication, should be invoked by an application whenever
 -- appropriate. The argument is the realm.

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs

@@ -7,6 +7,7 @@ import Data.Monoid
 import Servant hiding (BasicAuth)
 import Servant.Auth
 import Servant.Auth.JWT
+
 import Servant.Auth.Server.Internal.BasicAuth
 import Servant.Auth.Server.Internal.ConfigTypes
 import Servant.Auth.Server.Internal.Cookie
@@ -41,10 +42,10 @@ instance AreAuths '[] ctxs v where
   runAuths _ _ = mempty
 
 instance
-  ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
-  , IsAuth a v
+  ( AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
   , AreAuths as ctxs v
-  , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
+  , AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
+  , IsAuth a v
   )
   => AreAuths (a ': as) ctxs v
   where
@@ -70,8 +71,8 @@ class AppCtx ctx ls res where
   appCtx :: proxy ls -> Context ctx -> res -> App ls res
 
 instance
-  ( HasContextEntry ctxs ctx
-  , AppCtx ctxs rest res
+  ( AppCtx ctxs rest res
+  , HasContextEntry ctxs ctx
   )
   => AppCtx ctxs (ctx ': rest) (ctx -> res)
   where

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs

@@ -13,18 +13,18 @@ import GHC.Generics (Generic)
 import Servant.API (IsSecure (..))
 
 data IsMatch = Matches | DoesNotMatch
-  deriving (Eq, Show, Read, Generic, Ord)
+  deriving (Eq, Generic, Ord, Read, Show)
 
 data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect
-  deriving (Eq, Show, Read, Generic, Ord)
+  deriving (Eq, Generic, Ord, Read, Show)
 
 -- The @SameSite@ attribute of cookies determines whether cookies will be sent
 -- on cross-origin requests.
 --
 -- See <https://tools.ietf.org/html/draft-west-first-party-cookies-07 this document>
 -- for more information.
 data SameSite = AnySite | SameSiteStrict | SameSiteLax
-  deriving (Eq, Show, Read, Generic, Ord)
+  deriving (Eq, Generic, Ord, Read, Show)
 
 -- | @JWTSettings@ are used to generate cookies, and to verify JWTs.
 data JWTSettings = JWTSettings
@@ -77,7 +77,7 @@ data CookieSettings = CookieSettings
   , cookieXsrfSetting :: !(Maybe XsrfCookieSettings)
   -- ^ The optional settings to use for XSRF protection. Default: @Just def@.
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Generic, Show)
 
 instance Default CookieSettings where
   def = defaultCookieSettings
@@ -106,7 +106,7 @@ data XsrfCookieSettings = XsrfCookieSettings
   , xsrfExcludeGet :: !Bool
   -- ^ Exclude GET request method from XSRF protection.
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Generic, Show)
 
 instance Default XsrfCookieSettings where
   def = defaultXsrfCookieSettings

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs

@@ -19,11 +19,12 @@ import Network.HTTP.Types.Header (hCookie)
 import Network.Wai (Request, requestHeaders, requestMethod)
 import Servant (AddHeader, addHeader')
 import Servant.Auth.JWT (FromJWT, ToJWT)
+import System.Entropy (getEntropy)
+import Web.Cookie
+
 import Servant.Auth.Server.Internal.ConfigTypes
 import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT)
 import Servant.Auth.Server.Internal.Types
-import System.Entropy (getEntropy)
-import Web.Cookie
 
 cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr
 cookieAuthCheck ccfg jwtSettings = do
@@ -131,9 +132,9 @@ applySessionCookieSettings cookieSettings setCookie =
 -- provided response object with XSRF and session cookies. This should be used
 -- when a user successfully authenticates with credentials.
 acceptLogin
-  :: ( ToJWT session
-     , AddHeader mods "Set-Cookie" SetCookie response withOneCookie
+  :: ( AddHeader mods "Set-Cookie" SetCookie response withOneCookie
      , AddHeader mods "Set-Cookie" SetCookie withOneCookie withTwoCookies
+     , ToJWT session
      )
   => CookieSettings
   -> JWTSettings

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs

@@ -12,6 +12,7 @@ import Data.Maybe (fromMaybe)
 import Data.Time (UTCTime)
 import Network.Wai (requestHeaders)
 import Servant.Auth.JWT (FromJWT (..), ToJWT (..))
+
 import Servant.Auth.Server.Internal.ConfigTypes
 import Servant.Auth.Server.Internal.Types
 

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs

@@ -30,7 +30,7 @@ instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where
   throwAll e = throwAll e :<|> throwAll e
 
 instance
-  (ThrowAll (ToServant api (AsServerT m)), GenericServant api (AsServerT m))
+  (GenericServant api (AsServerT m), ThrowAll (ToServant api (AsServerT m)))
   => ThrowAll (api (AsServerT m))
   where
   throwAll = fromServant . throwAll