Versionbump: Reordered Settings.hs for Template haskell; stub instances.

2024-02-26 11:05:44 +01:00 · 2024-02-26 11:05:44 +01:00 · dae5abd45f
commit dae5abd45f
parent 130c703e0a
2 changed files with 98 additions and 66 deletions
--- a/src/Network/Minio/Instances.hs
+++ b/src/Network/Minio/Instances.hs
@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Stephan Barth <stephan.barth@ Gregor Kleen <gregor.kleen@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later

@ -15,6 +15,14 @@ import Network.Minio
 import qualified UnliftIO.Exception as UnliftIO
 import Control.Monad.Catch

+                  -- fromJSON, withObject, withScientific
+                  -- , (.!=), (.:?)
+import Data.Aeson (
+                  FromJSON(..)
+                  )
+--import Data.Aeson.Types
+
+import Data.ByteArray

 instance MonadThrow Minio where
  throwM = UnliftIO.throwIO
@ -26,3 +34,18 @@ instance MonadMask Minio where
  mask = UnliftIO.mask
  uninterruptibleMask = UnliftIO.uninterruptibleMask
  generalBracket acq rel inner = withUnliftIO $ \UnliftIO{..} -> generalBracket (unliftIO acq) ((unliftIO .) . rel) $ unliftIO . inner
+
+--deriving instance Generic ScrubbedBytes
+--deriving instance FromJSON ScrubbedBytes
+
+instance FromJSON ScrubbedBytes where
+  parseJSON = error "instance FromJSON ScrubbedBytes used but not implemented; implementation was neccessary due to version bump but cannot defined directly as intended, as ScrubbedBytes wants to take care that data cannot remain in memory after free, but Aeson does not care on loading. Hence, not implemented right now."
+  -- do
+  --  pj <- parseJSON x
+  --  return $ 
+
+--deriving newtype instance Generic AccessKey
+--deriving newtype instance Generic SecretKey
+
+deriving newtype instance FromJSON AccessKey
+deriving newtype instance FromJSON SecretKey
--- a/src/Settings.hs
+++ b/src/Settings.hs
@ -252,8 +252,18 @@ data AppSettings = AppSettings

    , appLegalExternal          :: Set LegalExternal
    
-    } deriving Show
+    }
+    -- removed deriving Show due to no Show instance for Minio.ConnectInfo in version minio-hs-1.7.0 any more (last version with Show instance was 1.6.0)
+    -- deriving Show

+data VerpMode = VerpNone
+              | Verp { verpPrefix :: Text, verpSeparator :: Char }
+  deriving (Eq, Show, Read, Generic)
+
+data ARCConf w = ARCConf
+  { arccMaximumGhost :: Int
+  , arccMaximumWeight :: w
+  } deriving (Eq, Ord, Read, Show, Generic)

 data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
             | JobsOffload
@ -268,6 +278,36 @@ data ApprootScope = ApprootUserGenerated | ApprootDefault
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite, Hashable)

+data TokenBucketConf = TokenBucketConf
+  { tokenBucketDepth :: Word64
+  , tokenBucketInvRate :: NominalDiffTime
+  , tokenBucketInitialValue :: Int64
+  } deriving (Eq, Ord, Show, Generic)
+
+data PrewarmCacheConf = PrewarmCacheConf
+  { precMaximumWeight :: Int
+  , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
+  , precSteps :: Natural
+  , precMaxSpeedup :: Rational
+  } deriving (Eq, Ord, Read, Show, Generic)
+
+data SettingBotMitigation
+  = SettingBotMitigationOnlyLoggedInTableSorting
+  | SettingBotMitigationUnauthorizedFormHoneypots
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite)
+
+data LegalExternal = LegalExternal
+  { externalLanguage :: Lang 
+  , externalImprint :: Text
+  , externalDataProtection :: Text
+  , externalTermsOfUse :: Text
+  , externalPayments :: Text    
+  }
+  deriving (Eq, Ord, Read, Show, Generic)
+
+
+

 newtype ServerSessionSettings
  = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
@ -370,6 +410,12 @@ instance FromJSON MemcachedConf where

    return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }

+
+instance FromJSON HaskellNet.PortNumber where
+  parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
+    Just int -> return $ fromIntegral (int :: Word16)
+    Nothing -> fail "Expected whole number of plausible size to denote port"
+
 instance FromJSON WidgetMemcachedConf where
  parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
    widgetMemcachedConf <- parseJSON v
@ -391,44 +437,13 @@ data SmtpAuthConf = SmtpAuthConf
  , smtpAuthPassword :: HaskellNet.Password
  } deriving (Show)

-data TokenBucketConf = TokenBucketConf
-  { tokenBucketDepth :: Word64
-  , tokenBucketInvRate :: NominalDiffTime
-  , tokenBucketInitialValue :: Int64
-  } deriving (Eq, Ord, Show, Generic)
-
-data VerpMode = VerpNone
-              | Verp { verpPrefix :: Text, verpSeparator :: Char }
-  deriving (Eq, Show, Read, Generic)
-
-data ARCConf w = ARCConf
-  { arccMaximumGhost :: Int
-  , arccMaximumWeight :: w
-  } deriving (Eq, Ord, Read, Show, Generic)
-
-data PrewarmCacheConf = PrewarmCacheConf
-  { precMaximumWeight :: Int
-  , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
-  , precSteps :: Natural
-  , precMaxSpeedup :: Rational
-  } deriving (Eq, Ord, Read, Show, Generic)
-
-data SettingBotMitigation
-  = SettingBotMitigationOnlyLoggedInTableSorting
-  | SettingBotMitigationUnauthorizedFormHoneypots
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-  deriving anyclass (Universe, Finite)
-
-data LegalExternal = LegalExternal
-  { externalLanguage :: Lang 
-  , externalImprint :: Text
-  , externalDataProtection :: Text
-  , externalTermsOfUse :: Text
-  , externalPayments :: Text    
-  }
-  deriving (Eq, Ord, Read, Show, Generic)
 makeLenses_ ''LegalExternal

+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''ResourcePoolConf

 nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
 pathPieceJSON ''ApprootScope
@ -497,17 +512,6 @@ instance FromJSON LdapConf where
        ldapPool <- o .: "pool"
        return LdapConf{..}

-deriveFromJSON
-  defaultOptions
-    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-    }
-  ''ResourcePoolConf
-
-instance FromJSON HaskellNet.PortNumber where
-  parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
-    Just int -> return $ fromIntegral (int :: Word16)
-    Nothing -> fail "Expected whole number of plausible size to denote port"
-
 deriveFromJSON
  defaultOptions
    { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
@ -542,14 +546,12 @@ instance FromJSON LprConf where
    lprQueue <- o .: "queue"
    return LprConf{..}

-instance FromJSON SmtpConf where
-  parseJSON = withObject "SmtpConf" $ \o -> do
-    smtpHost <- o .:? "host" .!= ""
-    smtpPort <- o .: "port"
-    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
-    smtpSsl <- o .: "ssl"
-    smtpPool <- o .: "pool"
-    return SmtpConf{..}
+instance FromJSON SmtpAuthConf where
+  parseJSON = withObject "SmtpAuthConf" $ \o -> do
+    smtpAuthType <- o .: "type"
+    smtpAuthUsername <- o .:? "user" .!= ""
+    smtpAuthPassword <- o .:? "pass" .!= ""
+    return SmtpAuthConf{..}

 deriveFromJSON
  defaultOptions
@ -558,12 +560,14 @@ deriveFromJSON
    }
  ''SmtpSslMode

-instance FromJSON SmtpAuthConf where
-  parseJSON = withObject "SmtpAuthConf" $ \o -> do
-    smtpAuthType <- o .: "type"
-    smtpAuthUsername <- o .:? "user" .!= ""
-    smtpAuthPassword <- o .:? "pass" .!= ""
-    return SmtpAuthConf{..}
+instance FromJSON SmtpConf where
+  parseJSON = withObject "SmtpConf" $ \o -> do
+    smtpHost <- o .:? "host" .!= ""
+    smtpPort <- o .: "port"
+    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
+    smtpSsl <- o .: "ssl"
+    smtpPool <- o .: "pool"
+    return SmtpConf{..}

 instance FromJSON JwtEncoding where
  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
@ -582,13 +586,18 @@ instance FromJSON Minio.ConnectInfo where
  parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do
    connectHost <- o .:? "host" .!= ""
    connectPort <- o .: "port"
-    connectAccessKey <- o .:? "access-key" .!= ""
-    connectSecretKey <- o .:? "secret-key" .!= ""
+    cvAccessKey <- o .:? "access-key" .!= ""
+    cvSecretKey <- o .:? "secret-key" .!= ""
+    let cvSessionToken = Nothing
+    let cv = Minio.CredentialValue{..}
+    let connectCreds = error "Minio.connectCreds was not overwritten by Minio.setCreds before evaluation!" -- Minio.CredsStatic constructor is not exported
    connectIsSecure <- o .: "is-secure"
    connectRegion <- o .:? "region" .!= ""
    connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True
    connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False
-    return Minio.ConnectInfo{..}
+    --return Minio.ConnectInfo{..}
+    let ret = Minio.ConnectInfo{..}
+    return $ Minio.setCreds cv ret


 instance FromJSON ServerSessionSettings where