hs-hath 1.1.2 → 1.2.0
raw patch · 53 files changed
+10211/−368 lines, 53 filesdep +asn1-encodingdep +asn1-typesdep +basementdep −cryptostoredep ~aesondep ~basedep ~base64new-component:exe:hath-bench
Dependencies added: asn1-encoding, asn1-types, basement, crypton-x509-validation, hourglass, pem
Dependencies removed: cryptostore
Dependency ranges changed: aeson, base, base64, bytestring, conduit, containers, crypton, crypton-connection, directory, ghc-prim, http-client, http-client-tls, http-conduit, http-types, memory, network, optparse-applicative, relude, resourcet, text, time, tls, tls-session-manager, transformers, unliftio, unordered-containers, wai, warp
Files
- CHANGELOG.md +19/−0
- app/Bench.hs +425/−0
- app/Migrate.hs +2/−2
- hs-hath.cabal +195/−14
- src/HathNetwork/RPC.hs +1/−1
- src/Interface/API.hs +68/−68
- src/LegacyCiphers.hs +8/−8
- src/Middleware.hs +89/−58
- src/Server.hs +135/−40
- src/Stats.hs +0/−1
- src/Storage/Database.hs +8/−3
- src/Storage/Filesystem.hs +7/−2
- src/Storage/Locate.hs +68/−23
- src/Storage/R2.hs +18/−12
- src/Types.hs +100/−48
- src/Utils.hs +6/−0
- test/FileURIRenderSpec.hs +27/−0
- test/FilesystemSpec.hs +21/−9
- test/Integration.hs +215/−49
- test/InterfaceAPIOptimizationSpec.hs +54/−0
- test/MockRPC.hs +32/−18
- test/R2Spec.hs +19/−9
- test/Spec.hs +7/−3
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/ASN1/Generate.hs +147/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/ASN1/Parse.hs +215/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS.hs +499/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Algorithms.hs +2293/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Attribute.hs +167/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/AuthEnveloped.hs +97/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Authenticated.hs +99/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Digested.hs +82/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Encrypted.hs +103/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Enveloped.hs +631/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Info.hs +194/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/OriginatorInfo.hs +184/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/PEM.hs +77/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Signed.hs +337/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Type.hs +89/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Util.hs +259/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/Cipher/RC2.hs +53/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/Cipher/RC2/Primitive.hs +236/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/Error.hs +69/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/AES.hs +145/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/RC2.hs +91/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/TripleDES.hs +66/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PEM.hs +35/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS12.hs +807/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS5.hs +238/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS5/PBES1.hs +418/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS8.hs +714/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS8/EC.hs +95/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/Util.hs +72/−0
- vendor/cryptostore-0.3.0.1/src/Crypto/Store/X509.hs +175/−0
CHANGELOG.md view
@@ -6,6 +6,25 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.2.0] - 2026-11-08++### Security+- **Gallery downloader**: file names from the server could contain path separators, letting a forged list write anywhere the client can. Lists must now carry a valid `DLHASH`, and names/types are limited to what the gallery system produces (official 1.6.6 fix)++### Changed+- **Protocol 1.6.6 (build 181)**: RPC moves to `/16/rpc` and `/16/dl`; replies must be signed with the client key and unsigned or altered ones are rejected. The build is fixed in code; the config `version` field is no longer used+- **Flood control** now matches the official client (10 hits draining 1/s, 60 s block; local network and RPC servers exempt)+- **Cache misses** are streamed to the requester while being fetched instead of after the full download+- **Hackage**: builds without extra flags; `cryptostore` is vendored with crypton baked in++### Fixed+- `threaded_proxy_test` reports real results; `servercmd` signatures are checked+- Files whose hash is `unknown` (generated on demand) can now be downloaded+- webp/avif Content-Type; a failed cache write no longer fails the request; shutdown no longer spins when the RPC server is unreachable++### Added+- `hath-bench`: a mock RPC server and benchmark that drives hs-hath or the official client+ ## [1.1.2] - 2026-01-31 ### Changed
+ app/Bench.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE BangPatterns #-}++-- | hath-bench: plays the H@H RPC server for a client running on this machine+-- (hs-hath or the official Java client), replays the measurements the real+-- server makes, and prints a scorecard.+--+-- The real server's quality inputs we can reproduce:+-- * servercmd speed_test / still_alive right after client_start+-- * servercmd threaded_proxy_test (the client measures someone else)+-- * other clients pulling /t/ (5 x 5 MB concurrently)+-- * readers pulling /h/ files, cold (srfetch + upstream) and warm+module Bench ( main ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.String.Interpolate ( i )+import qualified Data.Text as T+import Data.Time.Clock.System ( getSystemTime, systemSeconds )++import GHC.Clock ( getMonotonicTime )++import Network.Connection ( TLSSettings(TLSSettingsSimple) )+import qualified Network.HTTP.Client as HC+import Network.HTTP.Client.TLS ( mkManagerSettings )+import qualified Network.HTTP.Types as H+import Network.TLS ( defaultSupported )+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp++import Options.Applicative++import Relude++import System.Directory ( createDirectoryIfMissing, makeAbsolute )+import System.Environment ( getEnvironment )+import System.FilePath ( (</>) )+import System.Process ( CreateProcess(env), proc, readCreateProcess )++import Text.Printf ( printf )++import Control.Concurrent ( forkIO, threadDelay )++import Control.Exception ( try )++import UnliftIO ( pooledMapConcurrentlyN, timeout )++import Utils ( hash )++data Opts+ = Opts+ { oClientId :: !Text+ , oClientKey :: !Text+ , oRpcPort :: !Int+ , oClientPort :: !Int+ , oFiles :: !Int+ , oFileSize :: !Int+ , oUpDelayMs :: !Int+ , oUpKBps :: !Int+ , oWorkDir :: !FilePath+ , oClientHost :: !Text -- ^ where the bench reaches the client+ , oPublicHost :: !Text -- ^ where the client reaches the bench (also its rpc_server_ip)+ }++optsP :: Parser Opts+optsP+ = Opts+ <$> strOption (long "client-id" <> value "12345" <> showDefault <> help "Client ID of the client under test")+ <*> strOption+ (long "client-key"+ <> value "benchbenchbenchbench"+ <> showDefault+ <> help "Client key (the Java client wants 20 alphanumerics)")+ <*> option auto+ (long "rpc-port"+ <> value 19800+ <> showDefault+ <> help "Port of the fake RPC server, image server and speed-test target")+ <*> option auto (long "client-port" <> value 18443 <> showDefault <> help "Port the client is told to listen on")+ <*> option auto (long "files" <> value 30 <> showDefault <> help "Gallery size for the /h/ phases")+ <*> option auto (long "file-size" <> value 300000 <> showDefault <> help "Bytes per gallery file")+ <*> option auto+ (long "upstream-delay-ms"+ <> value 300+ <> showDefault+ <> help "Latency the fake image server adds before its first byte")+ <*> option auto+ (long "upstream-kbps"+ <> value 1000+ <> showDefault+ <> help "Fake image server bandwidth in KB/s (0 = unlimited)")+ <*> strOption (long "work-dir" <> value "bench-work" <> showDefault <> help "Where certs and client configs go")+ <*> strOption (long "client-host" <> value "127.0.0.1" <> showDefault <> help "Address of the client under test")+ <*> strOption+ (long "public-host"+ <> value "127.0.0.1"+ <> showDefault+ <> help "Address the client uses to reach this bench; anything but 127.0.0.1 listens on all IPv4 interfaces")++data GFile = GFile { gIndex :: !Int, gId :: !Text, gBytes :: !ByteString }++data Bench+ = Bench+ { bOpts :: !Opts+ , bP12 :: !ByteString+ , bFiles :: !(Map Text GFile)+ , bRpcCalls :: !(IORef (Map Text Int))+ , bSrfetch :: !(IORef Int)+ , bStarted :: !(MVar ())+ }++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ o <- execParser+ (info (optsP <**> helper) (fullDesc <> progDesc "Fake H@H RPC server that measures a local client"))+ when (oFileSize o < 64) $ die "--file-size must be at least 64"+ wd <- makeAbsolute (oWorkDir o)+ createDirectoryIfMissing True (wd </> "java" </> "data")+ p12 <- makeCert o wd+ writeClientConfigs o wd+ -- a fresh nonce per run gives new file ids, so the cold phase is really cold+ nonce <- systemSeconds <$> getSystemTime+ let files = mkGallery nonce (oFiles o) (oFileSize o)+ b <- Bench o p12 (Map.fromList [ ( gId f, f ) | f <- files ])+ <$> newIORef mempty+ <*> newIORef 0+ <*> newEmptyMVar+ void+ $ forkIO+ $ Warp.runSettings+ (Warp.setHost (if oPublicHost o == "127.0.0.1" then "127.0.0.1" else "*4")+ $ Warp.setPort (oRpcPort o) Warp.defaultSettings)+ (app b)+ putTextLn (instructions o wd)+ takeMVar (bStarted b)+ -- the Java client only accepts normal connections once client_start has returned+ putTextLn "client_start received, starting in 3 s"+ threadDelay 3000000+ mgr <- HC.newManager+ (mkManagerSettings (TLSSettingsSimple True False False defaultSupported) Nothing)+ { HC.managerResponseTimeout = HC.responseTimeoutMicro (90 * 1000000) }+ rows <- runPhases b mgr files+ calls <- readIORef (bRpcCalls b)+ report o rows calls+ unless (all rowPassed rows) exitFailure++-- | Self-signed cert packed as PKCS#12 with the client key as password, which is what get_cert returns.+makeCert :: Opts -> FilePath -> IO ByteString+makeCert o wd = do+ environment <- getEnvironment+ let openssl args = void+ $ readCreateProcess+ (proc "openssl" args)+ { env = Just (( "HATH_BENCH_PASS", toString (oClientKey o) ) : environment) }+ ""+ openssl+ [ "req", "-x509", "-newkey", "rsa:2048", "-nodes", "-days", "7", "-subj", "/CN=127.0.0.1"+ , "-keyout", wd </> "key.pem", "-out", wd </> "cert.pem" ]+ openssl+ [ "pkcs12", "-export", "-inkey", wd </> "key.pem", "-in", wd </> "cert.pem"+ , "-out", wd </> "cert.p12", "-passout", "env:HATH_BENCH_PASS"+ , "-name", "hath.network" ] -- the alias the Java client looks up+ readFileBS (wd </> "cert.p12")++writeClientConfigs :: Opts -> FilePath -> IO ()+writeClientConfigs o wd = do+ writeFileText (wd </> "java" </> "data" </> "client_login") [i|#{oClientId o}-#{oClientKey o}|]+ writeFileText+ (wd </> "hs-hath.dhall")+ [i|let CacheBackend = < CacheBackendSQLite | CacheBackendR2 | CacheBackendFilesystem >+let ClientProxy = { host : Text, port : Integer, auth : Optional { _1 : Text, _2 : Text } }+in { clientId = "#{oClientId o}"+ , key = "#{oClientKey o}"+ , version = "176"+ , proxy = None ClientProxy+ , downloadDir = "#{wd}/hs-download"+ , cachePath = "#{wd}/hs-cache.db"+ , cacheBackend = CacheBackend.CacheBackendSQLite+ , r2Config = None { r2Endpoint : Text, r2Bucket : Text }+ , lruCacheSize = +104857600+ }+|]++instructions :: Opts -> FilePath -> Text+instructions o wd+ = [i|hath-bench: fake RPC server on #{oPublicHost o}:#{oRpcPort o}. Start the client under test on #{oClientHost o}+(copy #{wd} there first if that is another machine):++ hs-hath: cd #{wd} && HATH_RPC_HOST=#{oPublicHost o}:#{oRpcPort o} hs-hath --config ./hs-hath.dhall --skip-startup-verify+ Java: cd #{wd}/java && java -jar /path/to/HentaiAtHome.jar --rpc_server_ip=#{oPublicHost o} --rpc_server_port=#{oRpcPort o}++(both configs use client id #{oClientId o}; pass --client-id/--client-key to change them)+Waiting for client_start...|]++mkGallery :: Int64 -> Int -> Int -> [ GFile ]+mkGallery nonce n size+ = [ GFile k fileId body+ | k <- [ 1 .. n ]+ , let prefix = encodeUtf8 ([i|hath-bench #{nonce} #{k} |] :: Text)+ body = prefix <> BS.replicate (size - BS.length prefix) 46+ fileId = [i|#{hash @Text body}-#{size}-1280-1707-jpg|] ]++-- | RPC endpoint, fake image server (/up) and speed-test target (/t) on one port.+app :: Bench -> Wai.Application+app b req respond = case Wai.pathInfo req of+ [ "15", "rpc" ] -> rpc False+ -- 1.6.6+ (build 181): same actions, signed responses+ [ "16", "rpc" ] -> rpc True+ [ "up", fileId ] -> upstream fileId+ [ "t", sizeText, _, testKey, _ ] -> testTarget sizeText testKey+ _ -> respond $ Wai.responseLBS H.status404 [] ""+ where+ o = bOpts b++ -- Not Wai.queryString: parseQuery also splits on ';', and the Java client sends+ -- add=fileindex;xres;fileid unescaped.+ param k+ = maybe "" (H.urlDecode True . BS.drop (BS.length k + 1))+ $ find ((k <> "=") `BS.isPrefixOf`)+ $ BSC.split '&' (BS.dropWhile (== 63) (Wai.rawQueryString req))++ -- hs-hath's servant client insists on the real server's content type,+ -- the Java client on a Content-Length+ rpcResponse body+ = respond+ $ Wai.responseLBS+ H.status200+ [ ( H.hContentType, "text/plain;charset=UTF-8" ), ( H.hContentLength, show (BS.length body) ) ]+ (LBS.fromStrict body)++ -- 1.6.6 signs replies: OK-<t>-<sha1("<t>-<key>" ++ concatMap ("\n" ++) lines)>+ okWith signed ls = do+ now <- systemSeconds <$> getSystemTime+ let sig = hash @Text (encodeUtf8 (T.concat ([i|#{now}-#{oClientKey o}|] : map ("\n" <>) ls)))+ status = if signed then [i|OK-#{now}-#{sig}|] else "OK"+ rpcResponse (encodeUtf8 (T.unlines (status : ls)))++ settings+ = [ [i|rpc_server_ip=#{oPublicHost o}|]+ , [i|host=#{oClientHost o}|]+ , [i|port=#{oClientPort o}|]+ -- what the real server sends; Java stalls non-local transfers on throttle_bytes=0+ , "throttle_bytes=640000000"+ , "disable_bwm=true"+ , "disklimit_bytes=1073741824"+ , "diskremaining_bytes=1073741824" ]++ rpc signed = do+ let ok = okWith signed+ let act = decodeUtf8 (param "act") :: Text+ atomicModifyIORef' (bRpcCalls b) (\m -> ( Map.insertWith (+) act 1 m, () ))+ now <- systemSeconds <$> getSystemTime+ case act of+ "server_stat" -> ok [ "min_client_build=1", "cur_client_build=999", [i|server_time=#{now}|] ]+ "client_login" -> ok settings+ "client_settings" -> ok settings+ "get_cert" -> rpcResponse (bP12 b)+ "client_start" -> tryPutMVar (bStarted b) () >> ok []+ "srfetch" -> do+ atomicModifyIORef' (bSrfetch b) (\n -> ( n + 1, () ))+ -- add = fileindex;xres;fileid+ let fileId = decodeUtf8 (BSC.takeWhileEnd (/= ';') (param "add")) :: Text+ ok [ [i|http://#{oPublicHost o}:#{oRpcPort o}/up/#{fileId}|] ]+ _ -> ok [] -- still_alive, get_blacklist, client_stop, ...++ upstream fileId = case Map.lookup fileId (bFiles b) of+ Nothing -> respond $ Wai.responseLBS H.status404 [] ""+ Just f -> do+ threadDelay (oUpDelayMs o * 1000)+ let body = gBytes f+ respond+ $ Wai.responseStream+ H.status200+ [ ( H.hContentType, "image/jpeg" ), ( H.hContentLength, show (BS.length body) ) ]+ $ \write flush -> forM_ (chunksOf 16384 body) $ \c -> do+ write (BB.byteString c) >> flush+ when (oUpKBps o > 0) $ threadDelay (BS.length c * 1000 `div` oUpKBps o)++ testTarget sizeText testKey = case readMaybe @Int (toString sizeText) of+ Nothing -> respond $ Wai.responseLBS H.status400 [] ""+ Just size+ | testKey == "broken403" -> respond $ Wai.responseLBS H.status403 [] ""+ -- no Content-Length and only half the bytes: the tester sees a clean, early EOF+ | testKey == "brokenshort" -> zeros [] (size `div` 2)+ | otherwise -> zeros [ ( H.hContentLength, show size ) ] size++ zeros headers n+ = respond+ $ Wai.responseStream H.status200 headers+ $ \write _ -> forM_ (chunksOf 65536 (BS.replicate n 48)) (write . BB.byteString)++chunksOf :: Int -> ByteString -> [ ByteString ]+chunksOf n bs+ | BS.null bs = []+ | otherwise = let ( a, rest ) = BS.splitAt n bs in a : chunksOf n rest++data Sample+ = Sample+ { sStatus :: !(Maybe Int) -- ^ Nothing: connection error or timeout+ , sTtfb :: !Double -- ^ seconds until response headers+ , sTotal :: !Double -- ^ seconds until the body is drained+ , sBytes :: !Int+ , sHead :: !ByteString -- ^ first bytes of the body+ }++-- | GET with redirects followed, timing headers and body separately.+fetch :: HC.Manager -> String -> IO Sample+fetch mgr url = do+ t0 <- getMonotonicTime+ r <- timeout (90 * 1000000) $ try @SomeException $ do+ req <- HC.parseRequest url+ HC.withResponse req mgr $ \resp -> do+ t1 <- getMonotonicTime+ let drain !n acc = HC.brRead (HC.responseBody resp) >>= \c -> if BS.null c+ then pure ( n, acc )+ else drain (n + BS.length c) (if BS.length acc < 256 then acc <> BS.take 256 c else acc)+ ( n, headBytes ) <- drain 0 ""+ t2 <- getMonotonicTime+ pure $ Sample (Just (H.statusCode (HC.responseStatus resp))) (t1 - t0) (t2 - t0) n headBytes+ t3 <- getMonotonicTime+ pure $ case r of+ Just (Right s) -> s+ _ -> Sample Nothing (t3 - t0) (t3 - t0) 0 ""++data Row+ = Row+ { rowName :: !Text+ , rowSamples :: ![ Sample ]+ , rowWall :: !Double+ , rowPassed :: !Bool+ , rowNote :: !Text+ }++runPhases :: Bench -> HC.Manager -> [ GFile ] -> IO [ Row ]+runPhases b mgr files = do+ now <- systemSeconds <$> getSystemTime+ let o = bOpts b+ base = [i|https://#{oClientHost o}:#{oClientPort o}|] :: String+ sha1 = hash @Text . encodeUtf8 @Text++ servercmd :: Text -> Text -> String+ servercmd cmd add+ = let+ sig = sha1 [i|hentai@home-servercmd-#{cmd}-#{add}-#{oClientId o}-#{now}-#{oClientKey o}|]+ in + [i|#{base}/servercmd/#{cmd}/#{add}/#{now}/#{sig}|]++ proxyTest :: Text -> String+ proxyTest k+ = servercmd+ "threaded_proxy_test"+ [i|hostname=#{oPublicHost o};protocol=http;port=#{oRpcPort o};testsize=1000000;testcount=5;testtime=#{now};testkey=#{k}|]++ speedKey = sha1 [i|hentai@home-speedtest-5000000-#{now}-#{oClientId o}-#{oClientKey o}|]++ fileUrl f+ = let+ stamp = T.take 10 (sha1 [i|#{now}-#{gId f}-#{oClientKey o}-hotlinkthis|])+ in + [i|#{base}/h/#{gId f}/keystamp=#{now}-#{stamp};fileindex=#{gIndex f};xres=org/#{gIndex f}.jpg|]++ -- run n requests with the given concurrency; the check sees all samples+ phase name conc urls check = do+ t0 <- getMonotonicTime+ ss <- pooledMapConcurrentlyN conc (fetch mgr) urls+ t1 <- getMonotonicTime+ let ( passed, note ) = check ss+ pure $ Row name ss (t1 - t0) passed note++ allFull size ss = all (\s -> sStatus s == Just 200 && sBytes s == size) ss+ bodyText = decodeUtf8 . sHead :: Sample -> Text+ bodyIs p ss = ( all (\s -> sStatus s == Just 200 && p (bodyText s)) ss, T.intercalate " " (bodyText <$> ss) )++ galleryPhase name expectFetches = do+ before <- readIORef (bSrfetch b)+ row <- phase name 4 (fileUrl <$> files) (\ss -> ( allFull (oFileSize o) ss, "" ))+ fetches <- subtract before <$> readIORef (bSrfetch b)+ pure row { rowPassed = rowPassed row && fetches == expectFetches+ , rowNote = [i|srfetch=#{fetches} (want #{expectFetches})|] }++ -- for poking the client from a third machine (e.g. a flood-control burst)+ writeFileText (oWorkDir o </> "urls.txt") (T.unlines (toText . fileUrl <$> files))+ sequence+ [ phase "servercmd still_alive" 1 [ servercmd "still_alive" "" ] (bodyIs (const True))+ , phase "servercmd speed_test" 2 (replicate 2 (servercmd "speed_test" "testsize=2500000"))+ (\ss -> ( allFull 2500000 ss, "" ))+ , phase "servercmd unsigned" 1 [ [i|#{base}/servercmd/still_alive//#{now}/0|] ]+ (\ss -> ( map sStatus ss == [ Just 403 ], "want 403" ))+ , phase "proxy_test healthy" 1 [ proxyTest "ok" ] (bodyIs ("OK:5-" `T.isPrefixOf`))+ , phase "proxy_test target 403" 1 [ proxyTest "broken403" ] (bodyIs (== "OK:0-0"))+ , phase "proxy_test short body" 1 [ proxyTest "brokenshort" ] (bodyIs (== "OK:0-0"))+ , phase "/t/ 5x5MB concurrent" 5+ [ [i|#{base}/t/5000000/#{now}/#{speedKey}/#{k}|] | k <- [ 1 .. 5 :: Int ] ]+ (\ss -> ( allFull 5000000 ss, "" ))+ , galleryPhase "/h/ cold (cache miss)" (length files)+ , galleryPhase "/h/ warm (cache hit)" 0+ ]++report :: Opts -> [ Row ] -> Map Text Int -> IO ()+report o rows calls = do+ printf "\nhath-bench results (client on %s:%d)\n\n" (toString (oClientHost o)) (oClientPort o)+ printf "%-24s %-14s %15s %15s %8s %s\n"+ ("phase" :: String) ("status" :: String) ("ttfb p50/p95" :: String)+ ("total p50/p95" :: String) ("MB/s" :: String) ("check" :: String)+ forM_ rows $ \r -> do+ let ss = rowSamples r+ statuses = T.unwords+ [ [i|#{maybe "err" (show @Text) s}x#{c}|] :: Text+ | ( s, c ) <- Map.toList (Map.fromListWith (+) [ ( sStatus x, 1 :: Int ) | x <- ss ]) ]+ ms f = [i|#{msAt 0.5 f ss}/#{msAt 0.95 f ss}|] :: Text+ mbps = fromIntegral (sum (sBytes <$> ss)) / max 1e-9 (rowWall r) / 1e6 :: Double+ printf "%-24s %-14s %15s %15s %8.1f %s %s\n"+ (toString (rowName r)) (toString statuses) (toString (ms sTtfb)) (toString (ms sTotal)) mbps+ (if rowPassed r then "ok" else "FAIL" :: String) (toString (rowNote r))+ printf "\nRPC calls seen: %s\n"+ (toString (T.unwords [ [i|#{a}x#{n}|] | ( a, n ) <- Map.toList calls ]))+ where+ msAt :: Double -> (Sample -> Double) -> [ Sample ] -> Int+ msAt p f ss = case sort (f <$> ss) of+ [] -> 0+ xs -> round (1000 * (xs List.!! min (length xs - 1) (floor (p * fromIntegral (length xs)))))
app/Migrate.hs view
@@ -42,7 +42,7 @@ import System.Directory ( doesDirectoryExist, doesFileExist, listDirectory ) import System.FilePath ( (</>), takeFileName ) -import Types ( FileURI, R2Config(..), RPCError(..), parseFileURI )+import Types ( FileURI, R2Config(..), RPCError(..), parseFileURI, renderFileURIText ) -- | Command line options data MigrateOptions@@ -274,6 +274,6 @@ fileURIToKey :: FileURI -> Text fileURIToKey uri = s4 <> "/" <> fileId where- fileId = show uri+ fileId = renderFileURIText uri s4 = T.take 4 fileId
hs-hath.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hs-hath-version: 1.1.2+version: 1.2.0 synopsis: A Haskell implementation of the Hentai@Home client description: Please see the README on GitHub at <https://github.com/pe200012/hs-hath#readme> category: Web@@ -85,13 +85,13 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory ==1.3.* , exceptions ==0.10.* , extra >=1.7 && <1.9 , filepath >=1.4 && <1.6 , hex-text ==0.1.*+ , hs-hath-cryptostore , hs-hath-minio , hs-hath-placeholder , hs-hath-polysemy-zoo@@ -137,6 +137,113 @@ , warp ==3.4.* default-language: GHC2021 +library hs-hath-cryptostore+ exposed-modules:+ Crypto.Store.ASN1.Generate+ Crypto.Store.ASN1.Parse+ Crypto.Store.Cipher.RC2+ Crypto.Store.Cipher.RC2.Primitive+ Crypto.Store.CMS+ Crypto.Store.CMS.Algorithms+ Crypto.Store.CMS.Attribute+ Crypto.Store.CMS.Authenticated+ Crypto.Store.CMS.AuthEnveloped+ Crypto.Store.CMS.Digested+ Crypto.Store.CMS.Encrypted+ Crypto.Store.CMS.Enveloped+ Crypto.Store.CMS.Info+ Crypto.Store.CMS.OriginatorInfo+ Crypto.Store.CMS.PEM+ Crypto.Store.CMS.Signed+ Crypto.Store.CMS.Type+ Crypto.Store.CMS.Util+ Crypto.Store.Error+ Crypto.Store.KeyWrap.AES+ Crypto.Store.KeyWrap.RC2+ Crypto.Store.KeyWrap.TripleDES+ Crypto.Store.PEM+ Crypto.Store.PKCS12+ Crypto.Store.PKCS5+ Crypto.Store.PKCS5.PBES1+ Crypto.Store.PKCS8+ Crypto.Store.PKCS8.EC+ Crypto.Store.Util+ Crypto.Store.X509+ other-modules:+ Paths_hs_hath+ autogen-modules:+ Paths_hs_hath+ hs-source-dirs:+ vendor/cryptostore-0.3.0.1/src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -w+ build-depends:+ aeson >=2.1 && <2.3+ , asn1-encoding ==0.9.*+ , asn1-types >=0.3.1 && <0.4+ , async ==2.2.*+ , base >=4.7 && <4.22+ , base64 ==1.0.*+ , basement >=0.0.16 && <0.1+ , bytestring >=0.11 && <0.13+ , co-log >=0.6 && <0.8+ , co-log-core ==0.3.*+ , co-log-polysemy >=0.0.1.5 && <0.0.2+ , conduit ==1.3.*+ , containers >=0.6 && <0.8+ , crypton ==1.0.*+ , crypton-connection ==0.4.*+ , crypton-x509 ==1.7.*+ , crypton-x509-store ==1.6.*+ , crypton-x509-validation ==1.6.*+ , dhall ==1.42.*+ , directory ==1.3.*+ , exceptions ==0.10.*+ , extra >=1.7 && <1.9+ , filepath >=1.4 && <1.6+ , hex-text ==0.1.*+ , hourglass ==0.2.*+ , http-client ==0.7.*+ , http-client-tls ==0.3.*+ , http-conduit ==2.3.*+ , http-media ==0.8.*+ , http-types ==0.12.*+ , lrucache ==1.2.*+ , mason >=0.2.6 && <0.3+ , memory ==0.18.*+ , monad-control ==1.0.*+ , monad-loops ==0.4.*+ , mtl ==2.3.*+ , network >=3.1 && <3.3+ , optparse-applicative ==0.18.*+ , pem >=0.1 && <0.3+ , polysemy ==1.9.*+ , process ==1.6.*+ , relude ==1.2.*+ , resourcet ==1.3.*+ , safe-exceptions ==0.1.*+ , servant >=0.20.2 && <0.21+ , servant-client >=0.20.2 && <0.21+ , servant-client-core >=0.20.2 && <0.21+ , servant-server >=0.20.2 && <0.21+ , sqlite-simple ==0.4.*+ , stm ==2.5.*+ , string-interpolate ==0.3.*+ , suspend ==0.2.*+ , template-haskell >=2.19 && <2.24+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , timers ==0.2.*+ , tls >=2.0 && <2.4+ , tls-session-manager >=0.0.5 && <0.1+ , transformers ==0.6.*+ , unix ==2.8.*+ , unliftio ==0.2.*+ , unordered-containers ==0.2.*+ , wai ==3.2.*+ , wai-extra ==3.1.*+ , warp ==3.4.*+ default-language: GHC2021+ library hs-hath-minio exposed-modules: Lib.Prelude@@ -202,7 +309,6 @@ , crypton-connection ==0.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , data-default-class ==0.* , dhall ==1.42.* , digest ==0.*@@ -288,7 +394,6 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory ==1.3.* , exceptions ==0.10.*@@ -392,7 +497,7 @@ build-depends: aeson >=2.1 && <2.3 , async ==2.2.*- , base ==4.21.*+ , base >=4.18 && <4.22 , base64 ==1.0.* , bytestring >=0.11 && <0.13 , co-log >=0.6 && <0.8@@ -406,14 +511,13 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory ==1.3.* , exceptions ==0.10.* , extra >=1.7 && <1.9 , filepath >=1.4 && <1.6 , ghc-compact ==0.1.*- , ghc-prim ==0.13.*+ , ghc-prim >=0.10 && <0.14 , hex-text ==0.1.* , http-client ==0.7.* , http-client-tls ==0.3.*@@ -488,7 +592,6 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory ==1.3.* , exceptions ==0.10.*@@ -527,17 +630,95 @@ , text >=1 && <3 , time >=1.12 && <1.15 , timers ==0.2.*- , tls >=1 && <3+ , tls >=2.1.3 && <2.5 , tls-session-manager ==0.* , transformers ==0.6.* , unix ==2.8.* , unliftio ==0.2.* , unordered-containers ==0.2.*- , wai ==3.*+ , wai ==3.2.* , wai-extra ==3.1.*- , warp ==3.*+ , warp >=3.3.29 && <3.4.13 default-language: GHC2021 +executable hath-bench+ main-is: Bench.hs+ hs-source-dirs:+ app+ default-extensions:+ NoImplicitPrelude+ TypeApplications+ OverloadedStrings+ ScopedTypeVariables+ QuasiQuotes+ LambdaCase+ ViewPatterns+ MultiParamTypeClasses+ GADTs+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -main-is Bench+ build-depends:+ aeson >=2.1 && <2.3+ , async ==2.2.*+ , base >=4.7 && <4.22+ , base64 ==1.0.*+ , bytestring >=0.11 && <0.13+ , co-log >=0.6 && <0.8+ , co-log-core ==0.3.*+ , co-log-polysemy >=0.0.1.5 && <0.0.2+ , conduit ==1.3.*+ , containers >=0.6 && <0.8+ , crypton ==1.0.*+ , crypton-connection ==0.4.*+ , crypton-x509 ==1.7.*+ , crypton-x509-store ==1.6.*+ , dhall ==1.42.*+ , directory ==1.3.*+ , exceptions ==0.10.*+ , extra >=1.7 && <1.9+ , filepath >=1.4 && <1.6+ , hex-text ==0.1.*+ , hs-hath+ , http-client ==0.7.*+ , http-client-tls ==0.3.*+ , http-conduit ==2.3.*+ , http-media ==0.8.*+ , http-types ==0.12.*+ , lrucache ==1.2.*+ , mason >=0.2.6 && <0.3+ , memory ==0.18.*+ , monad-control ==1.0.*+ , monad-loops ==0.4.*+ , mtl ==2.3.*+ , network >=3.1 && <3.3+ , optparse-applicative ==0.18.*+ , polysemy ==1.9.*+ , process ==1.6.*+ , relude ==1.2.*+ , resourcet ==1.3.*+ , safe-exceptions ==0.1.*+ , servant >=0.20.2 && <0.21+ , servant-client >=0.20.2 && <0.21+ , servant-client-core >=0.20.2 && <0.21+ , servant-server >=0.20.2 && <0.21+ , sqlite-simple ==0.4.*+ , stm ==2.5.*+ , string-interpolate ==0.3.*+ , suspend ==0.2.*+ , template-haskell >=2.19 && <2.24+ , text >=2.0 && <2.2+ , time >=1.12 && <1.15+ , timers ==0.2.*+ , tls >=2.0 && <2.4+ , tls-session-manager >=0.0.5 && <0.1+ , transformers ==0.6.*+ , unix ==2.8.*+ , unliftio ==0.2.*+ , unordered-containers ==0.2.*+ , wai ==3.2.*+ , wai-extra ==3.1.*+ , warp ==3.4.*+ default-language: GHC2021+ executable hs-hath main-is: Main.hs hs-source-dirs:@@ -568,7 +749,6 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory ==1.3.* , exceptions ==0.10.*@@ -647,7 +827,6 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory , exceptions ==0.10.*@@ -703,7 +882,9 @@ main-is: Spec.hs other-modules: FilesystemSpec+ FileURIRenderSpec Integration+ InterfaceAPIOptimizationSpec MockRPC R2Spec Paths_hs_hath@@ -737,7 +918,6 @@ , crypton-connection ==0.4.* , crypton-x509 ==1.7.* , crypton-x509-store ==1.6.*- , cryptostore ==0.3.* , dhall ==1.42.* , directory , exceptions ==0.10.*@@ -745,6 +925,7 @@ , filepath , hex-text ==0.1.* , hs-hath+ , hs-hath-polysemy-zoo , hspec ==2.11.* , http-client ==0.7.* , http-client-tls ==0.3.*
src/HathNetwork/RPC.hs view
@@ -75,7 +75,7 @@ ClientStart -> log Info "Trying to start a session" >> startListening ClientStop -> log Info "Stopping a session" >> stopListening ClientLogin -> log Info "Logging in" >> login- CheckGalleryTask -> log Info "Checking for a gallery task" >> nextGalleryTask+ CheckGalleryTask -> log Info "Checking for a gallery task" >> (rightToMaybe <$> nextGalleryTask) NotifyGalleryCompletion metadata -> log Info "Notifying server that a gallery task has been completed" >> completeGalleryTask metadata
src/Interface/API.hs view
@@ -10,8 +10,6 @@ API , api , ServerCommand(..)- , DynCT- , WithDynamicContentType(..) -- * EHentai RPC , EHentaiAPI(..) , ehRPC@@ -29,9 +27,10 @@ , completeGalleryTask , downloadGalleryFile , reportFailures- , fetchResource+ , openResource , fetchBlacklist , runEHentaiAPIIO+ , renderServerCommand ) where import Crypto.Store.PKCS12 ( readP12FileFromMemory@@ -43,6 +42,7 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS+import qualified Data.List as List import Data.String.Interpolate ( i ) import qualified Data.Text as T import Data.Time.Clock.System ( SystemTime(systemSeconds), getSystemTime )@@ -50,17 +50,23 @@ import qualified Mason.Builder as BD -import Network.HTTP.Client ( HttpException+import Network.HTTP.Client ( BodyReader+ , HttpException , Manager , Request(responseTimeout, host, requestHeaders)- , Response(responseBody)+ , Response(responseBody, responseHeaders, responseStatus)+ , responseClose+ , responseOpen , defaultManagerSettings , newManager , parseRequest , responseTimeoutMicro ) import Network.HTTP.Media ( (//), (/:) )+import Network.HTTP.Client.TLS ( getGlobalManager ) import Network.HTTP.Simple ( httpLbs )+import Network.HTTP.Types ( hContentLength )+import qualified Network.HTTP.Types as HT import Polysemy import Polysemy.Error ( Error, errorToIOFinal, throw )@@ -100,17 +106,19 @@ , HathSettings , RPCError(CertificateFailure) , RPCResponse(statusCode)- , emptyMetadata+ , clientBuild , hentaiHeader , parseMetadata , parseRPCResponse , parseRPCResponse' , parseSettings+ , renderFileURIBytes+ , verifyRPCResponse ) import UnliftIO ( try ) -import Utils ( hash )+import Utils ( firstJustM, hash ) -- | Available server commands data ServerCommand@@ -123,40 +131,22 @@ deriving ( Show, Eq ) -- Custom type conversion for ServerCommand-instance FromHttpApiData ServerCommand where- {-# INLINE parseUrlPiece #-}- parseUrlPiece = \case- "still_alive" -> Right StillAlive- "threaded_proxy_test" -> Right ThreadedProxyTest- "speed_test" -> Right SpeedTest- "refresh_settings" -> Right RefreshSettings- "start_downloader" -> Right StartDownloader- "refresh_certs" -> Right RefreshCerts- cmd -> Left $ "Invalid command: " <> cmd--data DynCT- deriving ( Typeable )--instance MimeRender DynCT ByteString where- {-# INLINE mimeRender #-}- mimeRender _ = LBS.fromStrict--instance Accept DynCT where- {-# INLINE contentType #-}- contentType _ = ""--data WithDynamicContentType- = WithDynamicContentType- { contentType :: {-# UNPACK #-} !ByteString, content :: {-# UNPACK #-} !ByteString }+serverCommandNames :: [ ( Text, ServerCommand ) ]+serverCommandNames+ = [ ( "still_alive", StillAlive )+ , ( "threaded_proxy_test", ThreadedProxyTest )+ , ( "speed_test", SpeedTest )+ , ( "refresh_settings", RefreshSettings )+ , ( "start_downloader", StartDownloader )+ , ( "refresh_certs", RefreshCerts )+ ] -instance MimeRender DynCT WithDynamicContentType where- {-# INLINE mimeRender #-}- mimeRender _ = LBS.fromStrict . content+instance FromHttpApiData ServerCommand where+ parseUrlPiece cmd = maybeToRight ("Invalid command: " <> cmd) (List.lookup cmd serverCommandNames) -instance AllCTRender '[ DynCT ] WithDynamicContentType where- {-# INLINE handleAcceptH #-}- handleAcceptH _ _ (WithDynamicContentType ct content)- = Just ( LBS.fromStrict ct, LBS.fromStrict content )+-- | Wire name of a command, needed to verify the servercmd signature.+renderServerCommand :: ServerCommand -> Text+renderServerCommand c = maybe "" fst (find ((== c) . snd) serverCommandNames) data SpeedTest deriving ( Typeable )@@ -180,7 +170,7 @@ :> Capture "info" Text :> Capture "opts" Text :> Capture "filename" Text- :> Get '[DynCT] (Headers '[Header "Content-Length" Int] WithDynamicContentType)+ :> RawM :<|> "metrics" :> Get '[PlainText] Text :<|> "servercmd" :> Capture "command" ServerCommand@@ -283,7 +273,7 @@ (runClientM (ehAPIM params { acttime = Just (show currentTime)- , clientbuild = Just (version cfg)+ , clientbuild = Just clientBuild , actkey = Just $ makeKey params cfg currentTime , cid = Just (clientId cfg) })@@ -295,8 +285,12 @@ pure servantReq { responseTimeout = responseTimeoutMicro rpcTimeout } }) {-# INLINE k #-} interpret (\case- EhRPC params -> k params "/15/rpc"- EhGallery params -> k params "/15/dl") m+ -- get_cert is the raw PKCS#12 file, not a signed reply+ EhRPC params+ | act params == Just "get_cert" -> k params "/16/rpc"+ | otherwise -> verifyRPCResponse (encodeUtf8 (key cfg)) <$> k params "/16/rpc"+ -- the gallery list carries its own signature, checked by parseMetadata+ EhGallery params -> k params "/16/dl") m where rpcTimeout :: Int rpcTimeout = 60 * 1000000 -- 60 seconds in microseconds@@ -382,12 +376,11 @@ parseSettings <$> parseRPCResponse' x {-# INLINE nextGalleryTask #-}-nextGalleryTask :: EHentaiAPI -@> Maybe GalleryMetadata+-- | Left says why there is nothing to download (NO_PENDING_DOWNLOADS, or a refused list).+nextGalleryTask :: [ EHentaiAPI, Reader ClientConfig ] >@> Either Text GalleryMetadata nextGalleryTask = do- m <- parseMetadata <$> ehGallery emptyRPCParams { act = Just "fetchqueue" }- if m == emptyMetadata- then return Nothing- else return $ Just m+ cfg <- ask @ClientConfig+ parseMetadata (encodeUtf8 (key cfg)) <$> ehGallery emptyRPCParams { act = Just "fetchqueue" } {-# INLINE completeGalleryTask #-} completeGalleryTask :: GalleryMetadata -> EHentaiAPI -@> ()@@ -415,7 +408,7 @@ >>= \case Left _ -> pure Nothing Right bytes -> do- if hash bytes /= galleryFileHash file+ if maybe False (/= hash bytes) (galleryFileHash file) then do modify @[ Text ]@@ -436,37 +429,44 @@ if null urls then operate (retries + 1) -- we did not get a valid URL, might be a network error- else maybe (operate (retries + 1)) (pure . Just) . asum- =<< traverse (download . BSC.unpack) urls+ else do+ -- `traverse` would execute every fallback download eagerly.+ -- We need monadic short-circuiting to stop after the first success.+ firstJustM (download . BSC.unpack) urls >>= maybe (operate (retries + 1)) (pure . Just) {-# INLINE reportFailures #-} reportFailures :: [ Text ] -> EHentaiAPI -@> () reportFailures reports = void $ ehRPC emptyRPCParams { act = Just "dlfails", add = Just $ T.intercalate ";" reports } -fetchResource :: FileURI- -> ( ByteString, ByteString )- -> [ EHentaiAPI, Reader ClientConfig, Error RPCError, Embed IO ] >@> Maybe ByteString-fetchResource fileURI ( fileIndex, xres ) = do+-- | Ask the RPC server where a static-range file lives and open the first source+-- that answers 200 with the expected length, as the official ProxyFileDownloader+-- does. The caller streams the body and must close the response.+openResource :: FileURI+ -> ( ByteString, ByteString )+ -> [ EHentaiAPI, Reader ClientConfig, Error RPCError, Embed IO ] >@> Maybe (Response BodyReader)+openResource fileURI ( fileIndex, xres ) = do urls <- parseRPCResponse' =<< ehRPC emptyRPCParams { act = Just "srfetch", add = Just [i|#{fileIndex};#{xres};#{fileURI}|] } cfg <- ask @ClientConfig- asum- <$> traverse- (download [i|#{clientId cfg}-#{hash @ByteString $ encodeUtf8 (key cfg) <> show fileURI}|]- . BSC.unpack)- urls+ let token = [i|#{clientId cfg}-#{hash @ByteString $ encodeUtf8 (key cfg) <> renderFileURIBytes fileURI}|]+ embed $ do+ mgr <- getGlobalManager+ firstJustM (open mgr token . BSC.unpack) urls where- download token url = case parseRequest url of+ open mgr token url = case parseRequest url of Nothing -> pure Nothing- Just req -> do- bytes <- embed- $ LBS.toStrict . responseBody- <$> httpLbs @IO req { requestHeaders = ( "Hath-Request", token ) : hentaiHeader }- if hash bytes /= fileHash fileURI- then pure Nothing- else return $ Just bytes+ Just req -> try @IO @HttpException+ (responseOpen req { requestHeaders = ( "Hath-Request", token ) : hentaiHeader } mgr)+ >>= \case+ Right resp+ | HT.statusCode (responseStatus resp) == 200+ , List.lookup hContentLength (responseHeaders resp) == Just (show (fileSize fileURI)) ->+ pure (Just resp)+ | otherwise -> responseClose resp $> Nothing+ -- connection error or wrong answer: firstJustM tries the next source+ Left _ -> pure Nothing fetchBlacklist :: Int -> [ EHentaiAPI, Error RPCError ] >@> [ Text ] fetchBlacklist deltaTime = do
src/LegacyCiphers.hs view
@@ -139,34 +139,34 @@ aes128cbc BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128- in + in (\iv input -> let output = cbcEncrypt ctx (makeIV_ iv) input- in + in ( output, takelast 16 output )) aes128cbc BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128- in + in (\iv input -> let output = cbcDecrypt ctx (makeIV_ iv) input- in + in ( output, takelast 16 input )) aes256cbc :: BulkDirection -> BulkKey -> BulkBlock aes256cbc BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256- in + in (\iv input -> let output = cbcEncrypt ctx (makeIV_ iv) input- in + in ( output, takelast 16 output )) aes256cbc BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256- in + in (\iv input -> let output = cbcDecrypt ctx (makeIV_ iv) input- in + in ( output, takelast 16 input ))
src/Middleware.hs view
@@ -9,10 +9,15 @@ , IP(..) , IPRecord(..) , timeWindow+ , checkRateLimit+ , isLocalIP+ , parseIPv4 ) where import Control.Exception ( finally ) +import Data.Bits ( shiftR, (.&.) )+ import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as HashMap @@ -21,7 +26,13 @@ import qualified Metrics.Gauge as Gauge import Network.HTTP.Types ( hAccept )-import Network.Socket ( HostAddress, HostAddress6, SockAddr(..) )+import Network.Socket ( HostAddress+ , HostAddress6+ , SockAddr(..)+ , hostAddress6ToTuple+ , hostAddressToTuple+ , tupleToHostAddress+ ) import Network.Wai ( Middleware , mapResponseHeaders , rawPathInfo@@ -39,18 +50,23 @@ import Utils ( tooManyRequestsResponse ) -timeWindow :: Double-timeWindow = 10 * 60 -- 10 minutes in seconds+-- | Mirrors the official client's flood control (HTTPServer.FloodControlEntry):+-- every request adds one hit, hits drain at one per second, and more than+-- 'floodLimit' hits blocks the IP for 'blockSeconds'.+floodLimit :: Int+floodLimit = 10 -maxRequests :: Int8-maxRequests = 5+blockSeconds :: Double+blockSeconds = 60 --- Data types for tracking requests--- Note: Lists cannot be unpacked, so we use strict spine with explicit strictness+-- | Entries idle for this long carry no state worth keeping (any block has expired).+timeWindow :: Double+timeWindow = 60+ data IPRecord- = IPRecord { earlistRequestTime :: !Double -- ^ Time of the first request- , requestTimes :: !Int8 -- ^ Number of requests in the time window- , bannedUntil :: !Double -- ^ When the ban expires+ = IPRecord { hitCount :: !Int -- ^ Hits left after draining+ , lastHit :: !Double -- ^ Monotonic time of the last counted hit+ , bannedUntil :: !Double -- ^ When the block expires } deriving ( Show ) @@ -73,64 +89,79 @@ globalIPMap :: IORef IPMap globalIPMap = unsafePerformIO $ newIORef HashMap.empty -{-# NOINLINE globalIPMapCounter #-}-globalIPMapCounter :: IORef Int-globalIPMapCounter = unsafePerformIO $ newIORef 0---- Create a new rate limiting middleware-rateLimitMiddleware :: Middleware-rateLimitMiddleware app req k+-- | Flood control for /h/. Local addresses and those the predicate exempts+-- (the RPC servers, as in the official client) are never limited.+rateLimitMiddleware :: (IP -> IO Bool) -> Middleware+rateLimitMiddleware exempt app req k | "/h/" `BS.isPrefixOf` rawPathInfo req = do now <- getMonotonicTime let sockAddr = remoteHost req case getIP sockAddr of Nothing -> app req k -- If we can't get IP, just allow the request- Just ip -> do- allowed <- checkRateLimit ip now- if allowed- then app req k- else k tooManyRequestsResponse+ Just ip+ | isLocalIP ip -> app req k+ | otherwise -> do+ skip <- exempt ip+ allowed <- if skip then pure True else checkRateLimit ip now+ if allowed+ then app req k+ else k tooManyRequestsResponse | otherwise = app req k -- Skip rate limiting for non-resource paths --- Check if request is allowed and update rate limit state------ return False if the request should be blocked-checkRateLimit :: IP -> Double -> IO Bool-checkRateLimit ip now = do- cnt <- readIORef globalIPMapCounter- if cnt > 100- then do- writeIORef globalIPMapCounter 0- writeIORef globalIPMap HashMap.empty- pure True- else do- writeIORef globalIPMapCounter (cnt + 1)- m <- readIORef globalIPMap- maybe firstRequest existingRequest (HashMap.lookup ip m)+-- | "a.b.c.d" or "::ffff:a.b.c.d", the form rpc_server_ip uses.+-- ponytail: IPv4 only; the RPC servers have no IPv6 addresses.+parseIPv4 :: ByteString -> Maybe IP+parseIPv4 s = case traverse (readMaybe @Int . decodeUtf8) (BS.split 46 v4) of+ Just [ a, b, c, d ]+ | all (\x -> x >= 0 && x <= 255) [ a, b, c, d ] -> Just+ (IPv4 (tupleToHostAddress ( fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d )))+ _ -> Nothing where- -- Handle first request from an IP by creating new record- firstRequest = do- modifyIORef' globalIPMap $ HashMap.insert ip (IPRecord now 1 0)- return True+ v4 = fromMaybe s (BS.stripPrefix "::ffff:" s) - -- Check if IP is banned, otherwise check request count- existingRequest record- | bannedUntil record > now = return False- | otherwise = checkAndUpdateRequests record+-- | Loopback, private and link-local addresses, which the official client+-- exempts from flood control (HTTPServer.localNetworkPattern).+isLocalIP :: IP -> Bool+isLocalIP (IPv4 ha) = localV4 (hostAddressToTuple ha)+isLocalIP (IPv6 ha) = case hostAddress6ToTuple ha of+ ( 0, 0, 0, 0, 0, 0, 0, 1 ) -> True+ -- IPv4-mapped (::ffff:a.b.c.d), as seen on dual-stack sockets+ ( 0, 0, 0, 0, 0, 0xffff, hi, lo ) -> localV4 ( byte hi 8, byte hi 0, byte lo 8, byte lo 0 )+ ( w, _, _, _, _, _, _, _ ) -> (w .&. 0xfe00) == 0xfc00 -- fc00::/7+ where+ byte w n = fromIntegral (w `shiftR` n) - -- Check if requests are within rate limit window and update accordingly- checkAndUpdateRequests record- = if now - earlistRequestTime record <= timeWindow- then if requestTimes record > maxRequests- then do- -- Ban the IP for 5 minutes- modifyIORef' globalIPMap $ HashMap.insert ip (record { bannedUntil = now + 5 * 60 })- return False- else do- modifyIORef' globalIPMap- $ HashMap.insert ip (record { requestTimes = requestTimes record + 1 })- return True- else return True+localV4 :: ( Word8, Word8, Word8, Word8 ) -> Bool+localV4 = \case+ ( 127, _, _, _ ) -> True+ ( 10, _, _, _ ) -> True+ ( 192, 168, _, _ ) -> True+ ( 172, b, _, _ ) -> b >= 16 && b <= 31+ ( 169, 254, _, _ ) -> True+ _ -> False++-- | Count a hit for the IP; False if the request should be blocked.+checkRateLimit :: IP -> Double -> IO Bool+checkRateLimit ip now = atomicModifyIORef' globalIPMap $ \m0 ->+ let+ -- ponytail: O(n) prune once the map is large; fine for the few hundred IPs a client sees per minute+ m = if HashMap.size m0 > 1000+ then HashMap.filter ((> now - timeWindow) . lastHit) m0+ else m0+ in + case HashMap.lookup ip m of+ Just r+ | bannedUntil r > now -> ( m, False ) -- blocked requests are not counted, as in the official client+ old -> let+ r0 = fromMaybe (IPRecord 0 now 0) old+ hits = max 0 (hitCount r0 - floor (now - lastHit r0)) + 1+ blocked = hits > floodLimit+ r = IPRecord { hitCount = hits+ , lastHit = now+ , bannedUntil = if blocked then now + blockSeconds else bannedUntil r0+ }+ in + ( HashMap.insert ip r m, not blocked ) type KeystampMap = HashMap ByteString ( Int, Double )
src/Server.hs view
@@ -7,6 +7,7 @@ ( startServer , ServerAction(..) , makeApplication+ , mkServerLoopContext , CacheRunner(..) , IPMap , KeystampMap@@ -26,13 +27,13 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC+import Data.ByteString.Builder ( byteString ) import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map import Data.String.Interpolate ( i ) import qualified Data.Text as Text-import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) import Data.Time.Clock.System ( SystemTime(systemSeconds), getSystemTime ) import Data.X509 ( CertificateChain, PrivKey ) @@ -49,11 +50,11 @@ import Interface.API ( API , EHentaiAPI , ServerCommand(..)- , WithDynamicContentType(WithDynamicContentType) , api , downloadGalleryFile , fetchBlacklist , nextGalleryTask+ , renderServerCommand , runEHentaiAPI , runEHentaiAPIIO , startListening@@ -66,19 +67,27 @@ import Middleware -import Network.HTTP.Client ( brReadSome+import qualified Network.HTTP.Client as HC+import Network.HTTP.Client ( Manager+ , brRead , newManager , parseRequest , withResponse ) import Network.HTTP.Client.TLS ( tlsManagerSettings )-import Network.HTTP.Simple ( getResponseBody )-import Network.HTTP.Types ( status200, status404 )+import Network.HTTP.Simple ( getResponseBody, getResponseStatusCode )+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types ( hContentLength+ , hContentType+ , status200+ , status404+ ) import Network.TLS ( Credentials(Credentials), Version(..) ) import Network.TLS.Extra ( ciphersuite_all ) import Network.Wai ( Middleware , Request(requestMethod) , responseLBS+ , responseStream ) import Network.Wai.Handler.Warp ( defaultSettings, setPort ) import Network.Wai.Handler.WarpTLS ( OnInsecure(AllowInsecure)@@ -142,7 +151,7 @@ import Types ( CacheBackend(..) , ClientConfig , ClientConfig(..)- , FileURI(fileExt)+ , FileURI(fileExt, fileSize) , GalleryFile(..) , GalleryMetadata(..) , HathSettings(..)@@ -158,6 +167,7 @@ , race , readTChan , replicateConcurrently+ , timeout , withAsync , writeTChan )@@ -172,6 +182,15 @@ maxTimeDrift :: Int64 maxTimeDrift = 600 +-- | Official Settings.MAX_KEY_TIME_DRIFT, used for servercmd.+maxCommandTimeDrift :: Int64+maxCommandTimeDrift = 300++-- | Whole-download cap for one threaded_proxy_test request.+-- ponytail: one total timeout; the official client uses 10 s connect + 60 s per read.+testTimeoutMicros :: Int+testTimeoutMicros = 60 * 1000000+ data ServerAction = Reload | Cert | GracefulShutdown data GalleryTask = GalleryTask@@ -220,6 +239,34 @@ -- ^ Cache backend interpreter (SQLite, R2, or Filesystem) } +mkServerLoopContext+ :: ClientConfig+ -> TVar HathSettings+ -> TChan ServerAction+ -> TChan GalleryTask+ -> Bool+ -> Bool+ -> CacheRunner+ -> StatsEnv+ -> ServerLoopContext+mkServerLoopContext cfg settings action gallery disableRL trustProxy cacheRunner statsEnv+ = ServerLoopContext+ { loopConfig = cfg+ , loopChannels = ServerChannels+ { serverActionChan = action+ , galleryTaskChan = gallery+ }+ , loopState = ServerState+ { serverSettings = settings+ , serverStatsEnv = statsEnv+ }+ , loopFlags = ServerFlags+ { disableRateLimit = disableRL+ , trustProxyHeaders = trustProxy+ }+ , loopCacheRunner = cacheRunner+ }+ -- Server implementation server :: Members '[ Embed IO@@ -257,7 +304,12 @@ resourceHandler (encodeUtf8 -> fileid) (parseURLParams . encodeUtf8 -> opts)- (encodeUtf8 -> filename) = do+ (encodeUtf8 -> filename)+ req+ respond+ -- answer HEAD like any other path instead of opening an upstream body nobody reads+ | requestMethod req == "HEAD" = embed $ respond $ responseLBS status200 hentaiHeader ""+ | otherwise = do currentTime <- embed getSystemTime cfg <- ask @ClientConfig when (abs (timestamp - systemSeconds currentTime) > maxTimeDrift)@@ -267,24 +319,33 @@ LocateURI { locateURIFilename = filename, locateURI = uri, locateURIOptions = opts } >>= \case Nothing -> throw err404- Just (Redirect url) -> throw+ Just (Stored (Redirect url)) -> throw $ err302 { errHeaders = [ ( "Location", url ), ( "Cache-Control", "public, max-age=600" ) ] }- Just (Record (fileRecordBytes -> bs)) -> do+ Just (Stored (Record (fileRecordBytes -> bs))) -> do incServed addUpload (BS.length bs)- return- $ addHeader @"Content-Length" (BS.length bs)- $ WithDynamicContentType mimeType bs+ embed $ respond $ responseLBS status200 (fileHeaders (BS.length bs)) (LBS.fromStrict bs)+ -- cache miss: relay upstream bytes as they arrive, like the official proxy mode+ Just (Streamed relay) -> do+ incServed+ addUpload (fileSize uri)+ embed+ $ respond+ $ responseStream status200 (fileHeaders (fileSize uri))+ $ \write flush -> relay (\chunk -> write (byteString chunk) >> flush) where+ fileHeaders :: Int -> [ HT.Header ]+ fileHeaders len = [ ( hContentType, mimeType ), ( hContentLength, show len ) ]+ mimeType = case fileExt uri of "jpg" -> "image/jpeg" "png" -> "image/png" "gif" -> "image/gif" "mp4" -> "video/mp4" "wbm" -> "video/webm"- "wbp" -> "video/webp"- "avf" -> "video/avif"+ "wbp" -> "image/webp"+ "avf" -> "image/avif" "jxl" -> "image/jxl" _ -> "application/octet-stream" @@ -295,7 +356,7 @@ rs = fromMaybe "" (Map.lookup "keystamp" opts) ( t, rk ) = BSC.span (/= '-') rs in - ( fromIntegral $ maybe 0 fst $ BSC.readInteger t, BS.tail rk )+ ( fromIntegral $ maybe 0 fst $ BSC.readInteger t, BS.drop 1 rk ) {-# INLINE challange #-} -- [i|#{timestamp}-#{fileid}-#{key cfg}-hotlinkthis|]@@ -311,8 +372,9 @@ <> BD.textUtf8 (key cfg) <> "-hotlinkthis") - serverCmdHandler command (parseURLParams . encodeUtf8 -> additional) _time _key- = case command of+ serverCmdHandler command rawAdditional commandTime commandKey+ = checkCommandKey+ >> case command of StillAlive -> plainText "I feel FANTASTIC and I'm still alive" ThreadedProxyTest -> let args = do@@ -351,12 +413,10 @@ Nothing -> throw err403 Just req -> do results <- embed $ replicateConcurrently testCount $ runTest testSize req mgr- let ( failed :: Int, millis :: Int64 )- = foldl' (\( f, t ) r -> case r of- Nothing -> ( f + 1, t )- Just v -> ( f, t + v )) ( 0, 0 ) results+ let succeeded = catMaybes results addUpload (testCount * fromIntegral testSize)- plainText [i|OK:#{failed}-#{millis}|]+ -- official format: OK:<successful tests>-<total millis of successful tests>+ plainText [i|OK:#{length succeeded}-#{sum succeeded}|] SpeedTest -> let testSize = maybe@@ -388,17 +448,45 @@ atomically $ writeTChan chan Cert plainText "" where+ additional = parseURLParams (encodeUtf8 rawAdditional)++ -- same check as the official client: only the RPC server knows our key+ checkCommandKey = do+ currentTime <- embed getSystemTime+ cfg <- ask @ClientConfig+ let expected+ = hash @Text+ $ encodeUtf8 @Text+ [i|hentai@home-servercmd-#{renderServerCommand command}-#{rawAdditional}-#{clientId cfg}-#{commandTime}-#{key cfg}|]+ when (abs (fromIntegral commandTime - systemSeconds currentTime) > maxCommandTimeDrift+ || commandKey /= expected)+ $ throw err403++ -- A test succeeds only if the whole body arrives with status 200 within the+ -- timeout (official: FileDownloader + getContentLength() >= testsize).+ runTest :: Int64 -> HC.Request -> Manager -> IO (Maybe Int64) runTest testSize req mgr = do- start <- getPOSIXTime- let phi 0 _ = do- end <- getPOSIXTime- return $ truncate $ realToFrac @POSIXTime @Double $ 1000 * (end - start)- phi n br = do- s <- LBS.length <$> brReadSome br 1024- phi (max 0 (n - s)) br- try @SomeException (withResponse req mgr (phi testSize . getResponseBody)) >>= \case- Left _ -> return Nothing- Right v -> return $ Just v+ start <- getMonotonicTime+ ok <- timeout testTimeoutMicros+ $ try @SomeException+ $ withResponse req mgr+ $ \resp -> let+ drain n+ | n <= 0 = pure True+ | otherwise = do+ chunk <- brRead (getResponseBody resp)+ -- an empty chunk is EOF: the body was shorter than promised+ if BS.null chunk+ then pure False+ else drain (n - fromIntegral (BS.length chunk))+ in+ if getResponseStatusCode resp == 200+ then drain testSize+ else pure False+ end <- getMonotonicTime+ pure $ case ok of+ Just (Right True) -> Just (truncate ((end - start) * 1000))+ _ -> Nothing {-# INLINE readInt #-} {-# SPECIALISE readInt :: ByteString -> Maybe Int #-}@@ -506,8 +594,11 @@ applyRateLimit = if disableRL then id- else rateLimitMiddleware+ else rateLimitMiddleware isRpcServer + -- dual-stack sockets would show RPC servers as ::ffff:a.b.c.d; Warp listens on IPv4 here+ isRpcServer ip = (\st -> Just ip `elem` (parseIPv4 <$> rpcServerIPs st)) <$> readTVarIO settings+ finalMiddleware :: Middleware finalMiddleware = applyRealIp . applyRateLimit @@ -595,11 +686,13 @@ -- This function repeatedly calls 'stopListening' until the RPC server -- acknowledges the shutdown request, then exits the process cleanly. gracefulShutdown :: ClientConfig -> IO a-gracefulShutdown cfg = go+gracefulShutdown cfg = go (3 :: Int) where- go = runEHentaiAPIIO cfg stopListening >>= \case- Right _ -> exitSuccess- Left _ -> go+ -- The official client sends client_stop once. Never spin when the RPC server is unreachable.+ go n = runEHentaiAPIIO cfg stopListening >>= \case+ Left _+ | n > 1 -> threadDelay 1000000 >> go (n - 1)+ _ -> exitSuccess -- | Refresh TLS certificates with exponential backoff retry logic. --@@ -700,8 +793,9 @@ metadata <- nextGalleryTask incDlTask case metadata of- Nothing -> log Info "No gallery task available"- Just md -> do+ Left "NO_PENDING_DOWNLOADS" -> log Info "No gallery task available"+ Left reason -> log Warning [i|Gallery download refused: #{reason}|]+ Right md -> do log Info [i|Starting download for gallery #{galleryID md}|] complete <- mapM (verifyAndDownload md) (galleryFileList md) when (and complete) (notifyGalleryCompletion md)@@ -715,7 +809,8 @@ if existing then BS.readFile filePath else return BS.empty- if galleryFileHash f == hash existingBytes+ -- a file generated on demand has no known hash; like the official client, keep it+ if not (BS.null existingBytes) && maybe True (== hash existingBytes) (galleryFileHash f) then log Info [i|#{galleryFileName f}.#{galleryFileExt f} already verified, skipping|] >> pure True else downloadGalleryFile md f >>= \case
src/Stats.hs view
@@ -95,7 +95,6 @@ dlBytesCounter errorCounter latencyGauge- data Stats m a where AddUpload :: Int -> Stats m () AddDownload :: Int -> Stats m ()
src/Storage/Database.hs view
@@ -16,7 +16,12 @@ import Relude hiding ( Reader, State, ask, evalState, get, modify, put ) -import Types ( FileRecord(..), FileURI, StorageResult(..) )+import Types ( FileRecord(..)+ , FileURI+ , StorageResult(..)+ , renderFileURIBytes+ , renderFileURIText+ ) {-# INLINE initializeDB #-} -- | Initialize database with required schema@@ -42,7 +47,7 @@ :: Members '[ Embed IO ] r => Connection -> KVStore FileURI StorageResult : r @> a -> r @> a runCache conn = interpret $ \case LookupKV uri -> do- let fid = show @Text uri+ let fid = renderFileURIText uri embed $ execute conn "UPDATE files SET lru_counter = lru_counter + 1 WHERE file_id = ?" (Only fid) results <- embed@@ -67,7 +72,7 @@ record UpdateKV uri Nothing -> let- fid = show @ByteString uri+ fid = renderFileURIBytes uri in embed $ execute conn "DELETE FROM files WHERE file_id = ?" (Only fid)
src/Storage/Filesystem.hs view
@@ -28,7 +28,12 @@ import System.Directory ( createDirectoryIfMissing, doesFileExist, removeFile ) import System.FilePath ( (</>), takeDirectory, takeFileName ) -import Types ( ClientConfig, FileURI(..), RPCError(..), StorageResult(..) )+import Types ( ClientConfig+ , FileURI(..)+ , RPCError(..)+ , StorageResult(..)+ , renderFileURIText+ ) import qualified Types as Ty import Utils ( log )@@ -39,7 +44,7 @@ fileURIToPath root uri = root </> s4 </> fileId where -- Sanitize to prevent directory traversal- fileId = takeFileName (show uri)+ fileId = takeFileName (toString $ renderFileURIText uri) s4 = T.unpack $ T.take 4 (T.pack fileId)
src/Storage/Locate.hs view
@@ -1,20 +1,33 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -module Storage.Locate ( LocateURI(..), Locate(..), locateResource, runLocate ) where+module Storage.Locate+ ( LocateURI(..)+ , Locate(..)+ , Located(..)+ , locateResource+ , runLocate+ , streamUpstream+ ) where import Colog ( Message, Severity(Info, Warning) ) import Colog.Polysemy ( Log ) +import Control.Concurrent ( forkIO )+import Control.Exception ( finally )+ import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS import qualified Data.Map as Map import Data.String.Interpolate ( i ) -import Interface.API ( EHentaiAPI, fetchResource )+import Interface.API ( EHentaiAPI, openResource ) +import qualified Network.HTTP.Client as HC+ import Polysemy-import Polysemy.Error ( Error )+import Polysemy.Error ( Error, catch )+import Polysemy.Final ( withWeavingToFinal ) import Polysemy.KVStore ( KVStore, lookupKV, updateKV ) import Polysemy.Operators import Polysemy.Reader ( Reader )@@ -27,7 +40,7 @@ import Types -import Utils ( log )+import Utils ( hash, log ) data LocateURI = LocateURI { locateURIFilename :: !ByteString@@ -35,9 +48,15 @@ , locateURIOptions :: !(Map ByteString ByteString) } +data Located+ = Stored !StorageResult+ -- | Cache miss being relayed from upstream: call it with a chunk writer.+ -- It closes the upstream connection and caches the file once it is complete.+ | Streamed !((ByteString -> IO ()) -> IO ())+ data Locate m a where -- | Fetch a specific resource from the server- LocateResource :: LocateURI -> Locate m (Maybe StorageResult)+ LocateResource :: LocateURI -> Locate m (Maybe Located) makeSem ''Locate @@ -49,6 +68,7 @@ , Reader ClientConfig , EHentaiAPI , Embed IO+ , Final IO , Stats , Log Message ]@@ -59,33 +79,36 @@ LocateResource uri -> do settings <- getSettings let fileURI = locateURI uri- s4 = SBS.take 4 . show $ fileURI+ s4 = SBS.toShort $ BS.take 4 $ renderFileURIBytes fileURI+ record content+ = Record+ FileRecord+ { fileRecordLRUCounter = 1+ , fileRecordS4 = decodeUtf8 s4+ , fileRecordFileId = renderFileURIText fileURI+ , fileRecordFileName = Just $ decodeUtf8 $ locateURIFilename uri+ , fileRecordBytes = content+ } -- if HashSet.member s4 (staticRanges settings) <-- we have a bug in setting parsing. wait for fix if True then lookupKV fileURI >>= \case- Just x@Redirect {} -> return $ Just x- Just x@Record {} -> return $ Just x+ Just x -> return $ Just $ Stored x Nothing -> case ( Map.lookup "fileindex" (locateURIOptions uri) , Map.lookup "xres" (locateURIOptions uri) ) of ( Just fileIndex, Just xres ) -> log Info [i|Fetching resource: #{fileURI}|]- >> fetchResource fileURI ( fileIndex, xres )+ >> openResource fileURI ( fileIndex, xres ) >>= \case- Just content -> do+ Just resp -> do incFetched- addDownload (BS.length content)- let record- = Record- FileRecord- { fileRecordLRUCounter = 1- , fileRecordS4 = decodeUtf8 s4- , fileRecordFileId = show fileURI- , fileRecordFileName = Just $ decodeUtf8 $ locateURIFilename uri- , fileRecordBytes = content- }- updateKV fileURI $ Just record- pure $ Just record- Nothing -> do+ -- runs after the handler has returned, once the body has been relayed+ cacheIt <- deferToIO $ \content -> do+ addDownload (BS.length content)+ -- a failed cache write only costs us the next hit+ catch @RPCError (updateKV fileURI $ Just $ record content)+ $ \e -> log Warning [i|Cache write failed for #{fileURI}: #{e}|]+ pure $ Just $ Streamed $ streamUpstream fileURI resp (void . forkIO . cacheIt)+ Nothing -> do log Warning [i|Failed to fetch resource, sorry for you|] pure Nothing _ -> do@@ -94,3 +117,25 @@ else do log Info [i|Resource not in our ranges, rejecting: #{s4}|] pure Nothing++-- | Relay an upstream body chunk by chunk. If it arrives complete and its SHA-1+-- matches, hand the bytes to the continuation (the cache write). The upstream+-- connection is closed in every case, including the client going away.+streamUpstream :: FileURI+ -> HC.Response HC.BodyReader+ -> (ByteString -> IO ())+ -> (ByteString -> IO ())+ -> IO ()+streamUpstream fileURI resp whenComplete write = go [] `finally` HC.responseClose resp+ where+ go acc = HC.brRead (HC.responseBody resp) >>= \chunk -> if BS.null chunk+ then let+ content = BS.concat (reverse acc)+ in+ when (BS.length content == fileSize fileURI && hash content == fileHash fileURI)+ $ whenComplete content+ else write chunk >> go (chunk : acc)++-- | Lower a Sem action into IO so it can run after the request handler has returned.+deferToIO :: Member (Final IO) r => (x -> Sem r ()) -> Sem r (x -> IO ())+deferToIO k = withWeavingToFinal $ \s lower _ -> pure ((\x -> void (lower (k x <$ s))) <$ s)
src/Storage/R2.hs view
@@ -38,23 +38,28 @@ import Polysemy.Error ( Error, throw ) import Polysemy.KVStore ( KVStore(..) ) import Polysemy.Operators-import Polysemy.Reader ( Reader, asks ) import Relude hiding ( Reader, ask, asks ) import Storage.Database ( FileRecord(..) ) -import Types ( ClientConfig- , FileURI(..)+import Types ( FileURI(..) , RPCError(..) , StorageResult(..)+ , renderFileURIText ) import qualified Types as Ty import Utils ( log ) -- | R2 connection configuration built at runtime-data R2Connection = R2Connection { r2MinioConn :: !Minio.MinioConn, r2ConnBucket :: !Text }+data R2Connection+ = R2Connection+ { r2MinioConn :: !Minio.MinioConn+ , r2ConnBucket :: !Text+ , r2UrlCache :: !(AtomicLRU FileURI ( Double, ByteString ))+ -- ^ Presigned links. Lives here because runCacheR2 runs once per request.+ } -- | Build R2 connection from config + environment variables -- Reads R2_ACCESS_KEY and R2_SECRET_KEY from environment@@ -78,29 +83,30 @@ minioConn <- liftIO $ do manager <- newManager tlsManagerSettings Minio.mkMinioConn (setCreds creds $ setRegion "auto" baseConnInfo) manager- pure $ Right R2Connection { r2MinioConn = minioConn, r2ConnBucket = Ty.r2Bucket cfg }+ -- ponytail: fixed capacity; links expire after 10 min, so it only has to hold ~10 min of distinct hits+ urlCache <- newAtomicLRU (Just 100000)+ pure+ $ Right+ R2Connection+ { r2MinioConn = minioConn, r2ConnBucket = Ty.r2Bucket cfg, r2UrlCache = urlCache } -- | Generate R2 object key from FileURI -- Format: s4/hash-size-xres-yres-ext fileURIToKey :: FileURI -> Text fileURIToKey uri = s4 <> "/" <> fileId where- fileId = show uri+ fileId = renderFileURIText uri s4 = T.take 4 fileId -- | Run the cache with Cloudflare R2 -- Read operations silently degrade to Nothing on failure (with warning log) -- Write/delete operations propagate errors-runCacheR2 :: Members '[ Embed IO, Log Message, Reader ClientConfig, Error RPCError ] r+runCacheR2 :: Members '[ Embed IO, Log Message, Error RPCError ] r => R2Connection -> KVStore FileURI StorageResult : r @> a -> r @> a-runCacheR2 conn m = do- lruSize <- asks Ty.lruCacheSize- let entries = Just (fromIntegral (lruSize `div` 300)) -- Approximate number of entries based on avg url link size ~300 bytes- memCache <- embed $ newAtomicLRU entries- interpret (phi memCache) m+runCacheR2 conn = interpret (phi (r2UrlCache conn)) where bucket = r2ConnBucket conn
src/Types.hs view
@@ -18,28 +18,34 @@ , StorageResult(..) -- * Globals , hentaiHeader+ , clientBuild -- * Default values , defaultHathSettings , defaultClientConfig , emptyFileURI- , emptyMetadata -- * Parsing , parseSettings , parseMetadata , readClientConfig , parseFileURI+ , renderFileURIBytes+ , renderFileURIText , parseRPCResponse , parseRPCResponse'+ , verifyRPCResponse , reconstructRecord -- * Selectors , getPayload ) where import qualified Data.ByteString.Char8 as BS+import Data.Char ( isAsciiLower, isAsciiUpper, isDigit ) import qualified Data.ByteString.Short as SBS import qualified Data.HashSet as HashSet import qualified Data.Text as T +import qualified Mason.Builder as BD+ import Database.SQLite.Simple ( FromRow, ToRow ) import Dhall ( FromDhall(..), ToDhall(..), auto, input )@@ -54,19 +60,23 @@ import Relude hiding ( show ) -import Text.Printf ( printf )+import Utils ( hash ) {-# SPECIALISE hentaiHeader :: [ ( HeaderName, Text ) ] #-} {-# SPECIALISE hentaiHeader :: [ ( HeaderName, ByteString ) ] #-} hentaiHeader :: IsString a => [ ( HeaderName, a ) ] hentaiHeader = [ ( "Connection", "close" )- , ( "User-Agent", "Hentai@Home 176" )+ , ( "User-Agent", "Hentai@Home 1.6.6" ) , ( "Cache-Control", "public, max-age=31536000" )- , ( "Server", "Genetic Lifeform and Distributed Open Server 1.6.4" )+ , ( "Server", "Genetic Lifeform and Distributed Open Server 1.6.6" ) , ( "X-Content-Type-Options", "nosniff" ) ] +-- | The protocol level this client implements (official 1.6.6), sent as clientbuild.+clientBuild :: Text+clientBuild = "181"+ data ClientProxy = ClientProxy { host :: {-# UNPACK #-} !Text , port :: {-# UNPACK #-} !Integer@@ -98,7 +108,7 @@ = ClientConfig { clientId :: {-# UNPACK #-} !Text , key :: {-# UNPACK #-} !Text- , version :: {-# UNPACK #-} !Text+ , version :: {-# UNPACK #-} !Text -- ^ unused, kept so existing configs load; see 'clientBuild' , proxy :: {-# UNPACK #-} !(Maybe ClientProxy) , downloadDir :: {-# UNPACK #-} !Text , cachePath :: {-# UNPACK #-} !Text@@ -143,6 +153,8 @@ , checkIPOrigin :: {-# UNPACK #-} !Bool , floodControl :: {-# UNPACK #-} !Bool , staticRanges :: {-# UNPACK #-} !(HashSet ShortByteString)+ , rpcServerIPs :: ![ ByteString ]+ -- ^ As sent by the server, e.g. "::ffff:192.0.2.10" } deriving ( Show ) @@ -161,6 +173,7 @@ , checkIPOrigin = True , floodControl = True , staticRanges = mempty+ , rpcServerIPs = [] } parseSettings :: [ ByteString ] -> HathSettings@@ -177,6 +190,7 @@ ( "diskremaining_bytes", Just bytes ) -> s { diskRemainingBytes = bytes } ( "static_ranges", _ ) -> s { staticRanges = HashSet.fromList (SBS.toShort <$> BS.split ';' v) }+ ( "rpc_server_ip", _ ) -> s { rpcServerIPs = BS.split ';' v } _ -> s) defaultHathSettings data GalleryFile@@ -184,7 +198,7 @@ , galleryFileIndex :: {-# UNPACK #-} !Int , galleryFileName :: {-# UNPACK #-} !ByteString , galleryFileXRes :: {-# UNPACK #-} !ByteString- , galleryFileHash :: {-# UNPACK #-} !ByteString+ , galleryFileHash :: !(Maybe ByteString) -- ^ Nothing: generated on demand, unverifiable , galleryFileExt :: {-# UNPACK #-} !ByteString } deriving ( Eq )@@ -198,48 +212,55 @@ } deriving ( Eq ) -emptyMetadata :: GalleryMetadata-emptyMetadata- = GalleryMetadata- { galleryID = 0- , galleryFileCount = 0- , galleryMinXRes = ""- , galleryTitle = ""- , galleryFileList = []- }+-- | Parse a /16/dl fetchqueue reply (hathdl format). Left carries the reason it was+-- refused: NO_PENDING_DOWNLOADS and other non-lists, or a list failing the 1.6.6 checks.+-- The file list must carry DLHASH = sha1(client key ++ "\n" ++ line, per file line),+-- and names/types must be ones the gallery system can produce, which keeps a forged+-- list from writing outside the download directory.+parseMetadata :: ByteString -> ByteString -> Either Text GalleryMetadata+parseMetadata clientKey bytes = case break (== "FILELIST") (BS.split '\n' bytes) of+ ( _, [] ) -> Left $ decodeUtf8 $ BS.strip $ BS.take 64 bytes+ ( header, _ : rest ) -> do+ let fileLines = filter (not . BS.null) (takeWhile (/= "INFORMATION") rest)+ field k = listToMaybe [ BS.drop 1 v | l <- header, let ( f, v ) = BS.break (== ' ') l, f == k ]+ gid <- maybeToRight "invalid GID" $ mfilter (> 0) $ readIntExact =<< field "GID"+ minXRes <- maybeToRight "invalid MINXRES" $ mfilter validXRes $ field "MINXRES"+ when (field "DLHASH" /= Just (hash (clientKey <> foldMap ("\n" <>) fileLines)))+ $ Left "DLHASH does not match the file list"+ files <- traverse parseFile fileLines+ pure+ GalleryMetadata+ { galleryID = gid+ , galleryFileCount = length files+ , galleryMinXRes = minXRes+ , galleryTitle = fromMaybe "" (field "TITLE")+ , galleryFileList = files+ }+ where+ parseFile line = case BS.split ' ' line of+ [ page, index, xres, sha1, ext, name ]+ | Just p <- readIntExact page+ , Just ix <- readIntExact index+ , validName name+ , ext `elem` [ "jpg", "gif", "png", "webp" ] -> Right+ GalleryFile+ { galleryFilePage = p+ , galleryFileIndex = ix+ , galleryFileName = name+ , galleryFileXRes = xres+ , galleryFileHash = if sha1 == "unknown" then Nothing else Just sha1+ , galleryFileExt = ext+ }+ _ -> Left $ "invalid file line: " <> decodeUtf8 line -{-# NOINLINE emptyMetadata #-}+ validName n = not (BS.null n) && BS.length n <= 250 && not (".." `BS.isInfixOf` n)+ && BS.all (\c -> isAsciiUpper c || isAsciiLower c || isDigit c || c `elem` ("._-" :: String)) n -parseMetadata :: ByteString -> GalleryMetadata-parseMetadata bytes = foldl' go emptyMetadata (BS.lines bytes)- where- go metadata line = case BS.words line of- [] -> metadata- [ "GID", maybeGid ]- -> maybe metadata (\( gid, _ ) -> metadata { galleryID = gid }) (BS.readInt maybeGid)- [ "FILECOUNT", maybeCount ] -> maybe- metadata- (\( count, _ ) -> metadata { galleryFileCount = count })- (BS.readInt maybeCount)- [ "MINXRES", xres ] -> metadata { galleryMinXRes = xres }- ("TITLE" : rest) -> metadata { galleryTitle = BS.unwords rest }- [ maybePage, maybeFid, mxres, hash, ext, basename ]- -> case ( BS.readInt maybePage, BS.readInt maybeFid ) of- ( Just ( page, _ ), Just ( fid, _ ) ) -> metadata- { galleryFileList = GalleryFile- { galleryFilePage = page- , galleryFileIndex = fid- , galleryFileName = basename- , galleryFileXRes = mxres- , galleryFileHash = hash- , galleryFileExt = ext- }- : galleryFileList metadata- }- _ -> metadata- _ -> metadata+ validXRes x = x == "org" || (not (BS.null x) && BS.all isDigit x) - {-# INLINE go #-}+ readIntExact s = case BS.readInt s of+ Just ( n, "" ) -> Just n+ _ -> Nothing data FileURI = FileURI { fileHash :: {-# UNPACK #-} !ByteString@@ -250,9 +271,24 @@ } deriving ( Ord, Eq ) +renderFileURIBytes :: FileURI -> ByteString+renderFileURIBytes (FileURI { fileHash, fileSize, fileXRes, fileYRes, fileExt })+ = BD.toStrictByteString+ (BD.byteString fileHash+ <> "-"+ <> BD.intDec fileSize+ <> "-"+ <> BD.intDec fileXRes+ <> "-"+ <> BD.intDec fileYRes+ <> "-"+ <> BD.byteString fileExt)++renderFileURIText :: FileURI -> Text+renderFileURIText = decodeUtf8 . renderFileURIBytes+ instance Show FileURI where- show (FileURI { fileHash, fileSize, fileXRes, fileYRes, fileExt })- = printf "%s-%d-%d-%d-%s" (BS.unpack fileHash) fileSize fileXRes fileYRes (BS.unpack fileExt)+ show = toString . renderFileURIText emptyFileURI :: FileURI emptyFileURI = FileURI { fileHash = "", fileSize = 0, fileXRes = 0, fileYRes = 0, fileExt = "" }@@ -320,6 +356,22 @@ | statusCode response == "OK" = Right $ payload response | otherwise = Left $ RequestFailure $ decodeUtf8 $ statusCode response +-- | Check the 1.6.6 RPC signature. A signed reply starts with OK-<time>-<sha1>, the sha1+-- covering "<time>-<client key>" then "\n<line>" for every later line. A valid reply+-- comes back with that first line reduced to OK; a forged or unsigned OK becomes+-- RESPONSE_HASH_FAILED; any other status (FAIL, KEY_EXPIRED, ...) passes through.+verifyRPCResponse :: ByteString -> ByteString -> ByteString+verifyRPCResponse clientKey bytes = case BS.split '\n' bytes of+ status : rest+ | Just ( time, sig ) <- BS.break (== '-') <$> BS.stripPrefix "OK-" status+ , sig == "-" <> hash (time <> "-" <> clientKey <> foldMap ("\n" <>) body)+ -> BS.intercalate "\n" ("OK" : body)+ | "OK" `BS.isPrefixOf` status -> "RESPONSE_HASH_FAILED"+ where+ -- Java's split drops trailing empty lines, and the hash is over what it keeps+ body = reverse $ dropWhile BS.null $ reverse rest+ _ -> bytes+ {-# INLINE parseRPCResponse' #-} -- | Parse RPC responses effectfully parseRPCResponse' :: Member (Error RPCError) r => ByteString -> Sem r [ ByteString ]@@ -348,6 +400,6 @@ , fileRecordBytes = bytes } where- fileId = T.pack $ show uri+ fileId = renderFileURIText uri data StorageResult = Record FileRecord | Redirect ByteString
src/Utils.hs view
@@ -48,6 +48,12 @@ hasParam :: ByteString -> URLParams -> Bool hasParam = Map.member +{-# INLINE firstJustM #-}+-- | Run effects from left to right and stop at the first successful result.+firstJustM :: Monad m => (a -> m (Maybe b)) -> [ a ] -> m (Maybe b)+firstJustM _ [] = pure Nothing+firstJustM f (x : xs) = f x >>= maybe (firstJustM f xs) (pure . Just)+ bufferSending :: Int -> StepT m ByteString bufferSending 0 = Source.Stop bufferSending n
+ test/FileURIRenderSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module FileURIRenderSpec ( fileURIRenderSpecs, main ) where++import Relude++import Test.Hspec++import Types ( FileURI, parseFileURI, renderFileURIBytes, renderFileURIText )++main :: IO ()+main = hspec fileURIRenderSpecs++fileURIRenderSpecs :: Spec+fileURIRenderSpecs = describe "FileURI rendering" $ do+ it "round-trips a canonical file id through parse and byte rendering" $ do+ let fid = "abcdef1234567890-12345-1024-768-jpg"+ renderFileURIBytes (parseFileURI fid) `shouldBe` fid++ it "keeps text rendering consistent with byte rendering" $ do+ let uri = parseFileURI "deadbeefcafebabe-42-640-480-png"+ renderFileURIText uri `shouldBe` decodeUtf8 (renderFileURIBytes uri)++ it "keeps Show consistent with canonical text rendering" $ do+ let uri = parseFileURI "feedface12345678-2048-1920-1080-webp"+ show uri `shouldBe` toString (renderFileURIText uri)
test/FilesystemSpec.hs view
@@ -13,10 +13,11 @@ import Polysemy import Polysemy.Error ( Error, runError ) import Polysemy.KVStore ( KVStore, lookupKV, updateKV )+import Polysemy.Reader ( Reader, runReader ) import Storage.Filesystem ( runCacheFilesystem ) -import Relude hiding ( Reader )+import Relude hiding ( Reader, runReader ) import System.Directory ( doesFileExist ) import System.FilePath ( (</>) )@@ -24,7 +25,13 @@ import Test.Hspec -import Types ( FileURI, RPCError, parseFileURI )+import Types ( ClientConfig+ , FileURI+ , RPCError+ , StorageResult(..)+ , defaultClientConfig+ , parseFileURI+ ) -- | Sample file record for testing sampleRecord :: FileRecord@@ -51,21 +58,22 @@ -- | Run a program with Filesystem cache effect (silent logging) runWithFilesystemSilent :: FilePath- -> Sem '[KVStore FileURI FileRecord, Log Message, Error RPCError, Embed IO] a + -> Sem '[KVStore FileURI StorageResult, Log Message, Reader ClientConfig, Error RPCError, Embed IO] a -> IO (Either RPCError a) runWithFilesystemSilent root program = runM . runError @RPCError+ . runReader defaultClientConfig . runLogAction @IO @Message silentLogAction . runCacheFilesystem root $ program -- | Lookup with explicit type-lookupFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Sem r (Maybe FileRecord)+lookupFile :: Member (KVStore FileURI StorageResult) r => FileURI -> Sem r (Maybe StorageResult) lookupFile = lookupKV -- | Update with explicit type-updateFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Maybe FileRecord -> Sem r ()+updateFile :: Member (KVStore FileURI StorageResult) r => FileURI -> Maybe StorageResult -> Sem r () updateFile = updateKV filesystemSpecs :: Spec@@ -76,7 +84,7 @@ let root = tempDir </> "cache" -- Store- storeResult <- runWithFilesystemSilent root $ updateFile sampleURI (Just sampleRecord)+ storeResult <- runWithFilesystemSilent root $ updateFile sampleURI (Just $ Record sampleRecord) storeResult `shouldBe` Right () -- Verify file exists on disk (impl detail check)@@ -93,8 +101,9 @@ case retrieveResult of Left err -> expectationFailure $ "Error: " <> show err Right Nothing -> expectationFailure "Expected file record but got Nothing"- Right (Just record) -> do+ Right (Just (Record record)) -> do fileRecordBytes record `shouldBe` fileRecordBytes sampleRecord+ Right (Just (Redirect _)) -> expectationFailure "Expected cached record but got redirect" it "should return Nothing for non-existent file" $ do withSystemTempDirectory "hath-test" $ \tempDir -> do@@ -112,7 +121,7 @@ let root = tempDir </> "cache" -- Store first- _ <- runWithFilesystemSilent root $ updateFile sampleURI (Just sampleRecord)+ _ <- runWithFilesystemSilent root $ updateFile sampleURI (Just $ Record sampleRecord) -- Delete deleteResult <- runWithFilesystemSilent root $ updateFile sampleURI Nothing@@ -125,4 +134,7 @@ -- Verify lookup returns Nothing lookupResult <- runWithFilesystemSilent root $ lookupFile sampleURI- lookupResult `shouldBe` Right Nothing+ case lookupResult of+ Left err -> expectationFailure $ "Error: " <> show err+ Right Nothing -> pure ()+ Right (Just _) -> expectationFailure "Expected Nothing after delete"
test/Integration.hs view
@@ -18,7 +18,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map import Data.String.Interpolate ( i ) import qualified Data.Text as T@@ -41,6 +40,7 @@ , parseRequest , redirectCount , responseBody+ , responseHeaders , responseStatus ) import Network.HTTP.Types ( status200, status301, status403, status404, status429 )@@ -55,19 +55,11 @@ ) import Server ( CacheRunner(..)- , ServerAction(..)-+ , GalleryTask(..) , makeApplication-+ , mkServerLoopContext , startServer-- , IPMap-- , KeystampMap-- , GalleryTask(..)- ) @@ -81,9 +73,18 @@ import System.Environment ( setEnv )+import System.Timeout ( timeout ) +import Middleware ( IP(..), checkRateLimit, isLocalIP, parseIPv4 ) +import Network.Socket ( tupleToHostAddress, tupleToHostAddress6 ) +import Polysemy ( interpret )+import Polysemy.Error ( throw )+import Polysemy.KVStore ( KVStore(..) )+++ import Test.Hspec @@ -113,11 +114,16 @@ import Types ( CacheBackend(..)+ , RPCError(StorageError) , ClientConfig(..)+ , GalleryFile(..)+ , GalleryMetadata(..) , HathSettings(..) , defaultHathSettings+ , parseMetadata+ , verifyRPCResponse ) -- | Test configuration@@ -132,28 +138,75 @@ , cachePath = "/tmp/hs-hath-test-" <> show port <> ".db" , cacheBackend = CacheBackendSQLite , r2Config = Nothing+ , lruCacheSize = 100 * 1024 * 1024 } -withTestServer- :: MockRPCConfig+-- | A servercmd URL signed the way the RPC server signs it.+serverCmdUrl :: Int -> ClientConfig -> Text -> Text -> Int64 -> String+serverCmdUrl port cfg cmd add ts = [i|http://localhost:#{port}/servercmd/#{cmd}/#{add}/#{ts}/#{sig}|]+ where+ sig = hash @Text $ encodeUtf8 ([i|hentai@home-servercmd-#{cmd}-#{add}-#{clientId cfg}-#{ts}-#{key cfg}|] :: Text)++withTestServerConfigured+ :: Bool+ -> MockRPCConfig -> ClientConfig -> HathSettings -> (Int -> IO a) -> IO a-withTestServer mockCfg clientCfg settings action = withMockRPC mockCfg $ do+withTestServerConfigured disableRateLimit mockCfg clientCfg settings action+ = withConnection ":memory:" $ \conn -> do+ initializeDB conn+ withRunnerTestServer+ disableRateLimit+ CacheRunner { runCacheWith = runCache conn }+ mockCfg+ clientCfg+ settings+ action++withRunnerTestServer+ :: Bool+ -> CacheRunner+ -> MockRPCConfig+ -> ClientConfig+ -> HathSettings+ -> (Int -> IO a)+ -> IO a+withRunnerTestServer disableRateLimit cacheRunner mockCfg clientCfg settings action = withMockRPC mockCfg $ do setEnv "HATH_RPC_HOST" ("localhost:" <> show (mockPort mockCfg)) serverChan <- newTChanIO- ipMap <- newTVarIO HM.empty- ksVar <- newTVarIO HM.empty galleryHandler <- newTChanIO ssVar <- newTVarIO settings statsEnv <- newStatsEnv- withConnection ":memory:" $ \conn -> do- initializeDB conn- let cacheRunner = CacheRunner { runCacheWith = runCache conn }- app = makeApplication clientCfg ssVar serverChan galleryHandler ipMap ksVar False False cacheRunner statsEnv- Warp.testWithApplication (pure app) action+ let ctx = mkServerLoopContext+ clientCfg+ ssVar+ serverChan+ galleryHandler+ disableRateLimit+ False+ cacheRunner+ statsEnv+ app = makeApplication ctx+ Warp.testWithApplication (pure app) action +withTestServer+ :: MockRPCConfig+ -> ClientConfig+ -> HathSettings+ -> (Int -> IO a)+ -> IO a+withTestServer = withTestServerConfigured True++withRateLimitedTestServer+ :: MockRPCConfig+ -> ClientConfig+ -> HathSettings+ -> (Int -> IO a)+ -> IO a+withRateLimitedTestServer = withTestServerConfigured False+ -- | Helper to load test certificates loadTestCertificates :: IO (CertificateChain, [PrivKey]) loadTestCertificates = do@@ -202,7 +255,7 @@ mockContent = "TEST_FILE_CONTENT_123" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 0- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -231,7 +284,7 @@ mockContent = "TEST_FILE_CONTENT_123" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 1- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -247,14 +300,71 @@ responseStatus response `shouldBe` status403 responseBody response `shouldSatisfy` const True - it "applies rate limiting with 429 after bursts" $ do+ it "flood control matches the official client" $ do+ let ip = IPv4 (tupleToHostAddress ( 203, 0, 113, 7 ))+ t0 = 1000 :: Double+ -- ten quick hits pass, the eleventh blocks+ firstTen <- forM [ 0 .. 9 ] $ \k -> checkRateLimit ip (t0 + 0.1 * k)+ firstTen `shouldBe` replicate 10 True+ checkRateLimit ip (t0 + 1.0) `shouldReturn` False+ -- blocked for 60 s, then counting starts over+ checkRateLimit ip (t0 + 59) `shouldReturn` False+ checkRateLimit ip (t0 + 62) `shouldReturn` True+ -- one hit per second drains as fast as it fills+ let ip2 = IPv4 (tupleToHostAddress ( 203, 0, 113, 8 ))+ steady <- forM [ 0 .. 29 ] $ \k -> checkRateLimit ip2 (t0 + k)+ steady `shouldBe` replicate 30 True++ it "treats loopback, private and IPv4-mapped local addresses as local" $ do+ isLocalIP (IPv4 (tupleToHostAddress ( 127, 0, 0, 1 ))) `shouldBe` True+ isLocalIP (IPv4 (tupleToHostAddress ( 172, 20, 1, 1 ))) `shouldBe` True+ isLocalIP (IPv4 (tupleToHostAddress ( 172, 32, 1, 1 ))) `shouldBe` False+ isLocalIP (IPv4 (tupleToHostAddress ( 203, 0, 113, 7 ))) `shouldBe` False+ isLocalIP (IPv6 (tupleToHostAddress6 ( 0, 0, 0, 0, 0, 0xffff, 0x7f00, 1 ))) `shouldBe` True+ isLocalIP (IPv6 (tupleToHostAddress6 ( 0, 0, 0, 0, 0, 0xffff, 0xcb00, 0x7107 ))) `shouldBe` False+ isLocalIP (IPv6 (tupleToHostAddress6 ( 0xfd12, 0, 0, 0, 0, 0, 0, 1 ))) `shouldBe` True++ it "parses rpc_server_ip entries" $ do+ parseIPv4 "::ffff:192.0.2.10" `shouldBe` Just (IPv4 (tupleToHostAddress ( 192, 0, 2, 10 )))+ parseIPv4 "198.51.100.20" `shouldBe` Just (IPv4 (tupleToHostAddress ( 198, 51, 100, 20 )))+ parseIPv4 "300.1.1.1" `shouldBe` Nothing+ parseIPv4 "fe80::1" `shouldBe` Nothing++ it "accepts only RPC replies signed with the client key (1.6.6)" $ do+ let k = "test-secret-key-12345"+ sig t ls = hash @ByteString (t <> "-" <> k <> foldMap ("\n" <>) ls)+ verifyRPCResponse k ("OK-7-" <> sig "7" [ "a=1", "b=2" ] <> "\na=1\nb=2\n")+ `shouldBe` "OK\na=1\nb=2"+ verifyRPCResponse k ("OK-7-" <> sig "7" [ "a=1" ] <> "\na=2") `shouldBe` "RESPONSE_HASH_FAILED"+ verifyRPCResponse k "OK\na=1" `shouldBe` "RESPONSE_HASH_FAILED"+ verifyRPCResponse k "KEY_EXPIRED" `shouldBe` "KEY_EXPIRED"++ it "accepts only signed gallery lists with safe file names (1.6.6)" $ do+ let k = "test-secret-key-12345"+ meta signedFor files = BS.intercalate "\n"+ $ [ "GID 123", "FILECOUNT 2", "MINXRES org"+ , "DLHASH " <> hash (k <> foldMap ("\n" <>) signedFor), "TITLE t", "", "FILELIST" ]+ <> files+ <> [ "", "INFORMATION", "not a file line, not signed" ]+ ok files = meta files files+ good = [ "1 99 org " <> hash @ByteString "x" <> " jpg 001", "2 98 780 unknown webp p_2" ]+ files = fmap (fmap (\f -> ( galleryFileName f, galleryFileHash f )) . galleryFileList)+ files (parseMetadata k (ok good))+ `shouldBe` Right [ ( "001", Just (hash "x") ), ( "p_2", Nothing ) ]+ isLeft (parseMetadata k (meta good (take 1 good))) `shouldBe` True -- list tampered+ isLeft (parseMetadata k (ok [ "1 99 org h jpg ../../.ssh/x" ])) `shouldBe` True+ isLeft (parseMetadata k (ok [ "1 99 org h jpg .." ])) `shouldBe` True+ isLeft (parseMetadata k (ok [ "1 99 org h exe 001" ])) `shouldBe` True+ galleryID <$> parseMetadata k "NO_PENDING_DOWNLOADS\n" `shouldBe` Left "NO_PENDING_DOWNLOADS"++ it "exempts local addresses from flood control" $ do let mockPortNum = 19803 mockContent = "RL_TEST_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 2- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" - withTestServer mockConfig clientCfg defaultHathSettings { throttleBytes = 1 } $ \serverPort -> do+ withRateLimitedTestServer mockConfig clientCfg defaultHathSettings { throttleBytes = 1 } $ \serverPort -> do now <- getSystemTime let ts = systemSeconds now k = key clientCfg@@ -266,11 +376,11 @@ manager <- newManager defaultManagerSettings req0 <- parseRequest url- let burstRequests = replicate 7 req0+ let burstRequests = replicate 13 req0 responses <- forM burstRequests $ \req -> httpLbs req manager let statuses = responseStatus <$> responses- length (filter (== status429) statuses) `shouldSatisfy` (>= 2)+ statuses `shouldBe` replicate 13 status200 it "returns stats snapshot with non-negative counters" $ do let mockPortNum = 19804@@ -327,7 +437,7 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/still_alive/additional/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "still_alive" "additional" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status200 LBS.toStrict (responseBody resp) `shouldSatisfy` (\body -> "FANTASTIC" `BS.isInfixOf` body)@@ -341,7 +451,7 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/speed_test/testsize=1000/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "speed_test" "testsize=1000" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status200 @@ -401,7 +511,7 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/refresh_settings/additional/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "refresh_settings" "additional" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status200 @@ -414,7 +524,7 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/refresh_certs/additional/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "refresh_certs" "additional" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status200 @@ -427,16 +537,71 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/threaded_proxy_test/additional/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "threaded_proxy_test" "additional" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status403 + it "rejects unsigned /servercmd" $ do+ let mockConfig = defaultMockConfig { mockPort = 19830 }+ clientCfg = testConfig 30++ withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+ ts <- systemSeconds <$> getSystemTime+ manager <- newManager defaultManagerSettings+ req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/still_alive/additional/#{ts}/key|]+ resp <- httpLbs req manager+ responseStatus resp `shouldBe` status403++ it "reports successful tests for /servercmd/threaded_proxy_test, and does not hang on a failing target" $ do+ let mockConfig = defaultMockConfig { mockPort = 19831 }+ clientCfg = testConfig 31++ withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+ ts <- systemSeconds <$> getSystemTime+ manager <- newManager defaultManagerSettings+ let testKey = hash @Text $ encodeUtf8 ([i|hentai@home-speedtest-1000-#{ts}-#{clientId clientCfg}-#{key clientCfg}|] :: Text)+ proxyTest k = do+ -- the test server tests itself+ let add = [i|hostname=localhost;protocol=http;port=#{serverPort};testsize=1000;testcount=2;testtime=#{ts};testkey=#{k}|] :: Text+ req <- parseRequest (serverCmdUrl serverPort clientCfg "threaded_proxy_test" add ts)+ resp <- httpLbs req manager+ responseStatus resp `shouldBe` status200+ pure (LBS.toStrict (responseBody resp))++ ok <- proxyTest testKey+ ok `shouldSatisfy` ("OK:2-" `BS.isPrefixOf`)++ -- the target answers 403 with a short body; this used to spin forever+ failed <- timeout 10000000 (proxyTest "wrong-key")+ failed `shouldBe` Just "OK:0-0"++ it "still serves a fetched file when the cache write fails" $ do+ let mockContent = "WRITE_FAILS_CONTENT"+ mockConfig = defaultMockConfig { mockPort = 19832, mockFileContent = mockContent }+ clientCfg = testConfig 32+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt"+ brokenWrites = CacheRunner+ { runCacheWith = interpret $ \case+ LookupKV _ -> pure Nothing+ UpdateKV _ _ -> throw (StorageError "write refused")+ }++ withRunnerTestServer True brokenWrites mockConfig clientCfg defaultHathSettings $ \serverPort -> do+ ts <- systemSeconds <$> getSystemTime+ let inner = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{key clientCfg}-hotlinkthis|]+ keystamp = [i|#{ts}-#{decodeUtf8 (BS.take 10 (hash @ByteString inner))}|] :: Text+ manager <- newManager defaultManagerSettings+ req <- parseRequest [i|http://localhost:#{serverPort}/h/#{fileURIStr}/keystamp=#{keystamp};fileindex=1;xres=1024/f.txt|]+ resp <- httpLbs req manager+ responseStatus resp `shouldBe` status200+ responseBody resp `shouldBe` LBS.fromStrict mockContent+ it "serves file with jpg extension and correct mime type" $ do let mockPortNum = 19816 mockContent = "FAKE_JPG_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 15- fileURIStr = hash @Text mockContent <> "-123-1024-768-jpg"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-jpg" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -460,7 +625,7 @@ mockContent = "FAKE_PNG_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 16- fileURIStr = hash @Text mockContent <> "-123-1024-768-png"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-png" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -483,7 +648,7 @@ mockContent = "FAKE_GIF_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 17- fileURIStr = hash @Text mockContent <> "-123-1024-768-gif"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-gif" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -506,7 +671,7 @@ mockContent = "FAKE_MP4_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 18- fileURIStr = hash @Text mockContent <> "-123-1024-768-mp4"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-mp4" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -533,7 +698,7 @@ now <- getSystemTime let ts = systemSeconds now manager <- newManager defaultManagerSettings- req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/start_downloader/additional/#{ts}/key|]+ req <- parseRequest (serverCmdUrl serverPort clientCfg "start_downloader" "additional" ts) resp <- httpLbs req manager responseStatus resp `shouldBe` status200 @@ -542,7 +707,7 @@ mockContent = "FAKE_WEBM_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 20- fileURIStr = hash @Text mockContent <> "-123-1024-768-wbm"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-wbm" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -565,7 +730,7 @@ mockContent = "FAKE_WEBP_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 21- fileURIStr = hash @Text mockContent <> "-123-1024-768-wbp"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-wbp" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -582,13 +747,14 @@ response <- httpLbs request manager responseStatus response `shouldBe` status200+ find ((== "Content-Type") . fst) (responseHeaders response) `shouldBe` Just ( "Content-Type", "image/webp" ) it "serves file with avif extension" $ do let mockPortNum = 19823 mockContent = "FAKE_AVIF_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 22- fileURIStr = hash @Text mockContent <> "-123-1024-768-avf"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-avf" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -611,7 +777,7 @@ mockContent = "FAKE_JXL_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 23- fileURIStr = hash @Text mockContent <> "-123-1024-768-jxl"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-jxl" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -634,7 +800,7 @@ mockContent = "TIMEDRIFT_TEST" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 24- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -658,7 +824,7 @@ mockContent = "CACHED_CONTENT_TEST" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 25- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -687,7 +853,7 @@ mockContent = "MISSING_PARAM_TEST" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 26- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -710,7 +876,7 @@ mockContent = "NOT_FOUND_TEST" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 27- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -733,7 +899,7 @@ mockContent = "UNKNOWN_EXT_CONTENT" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 28- fileURIStr = hash @Text mockContent <> "-123-1024-768-xyz"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-xyz" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -757,7 +923,7 @@ mockContent = "FUTURE_TIME_TEST" mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 29- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do currentTime <- getSystemTime@@ -806,7 +972,7 @@ mockConfig = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent } clientCfg = testConfig 100 settings = defaultHathSettings { clientPort = 9900 }- fileURIStr = hash @Text mockContent <> "-123-1024-768-txt"+ fileURIStr = hash @Text mockContent <> "-" <> show (BS.length mockContent) <> "-1024-768-txt" withStartServer mockConfig clientCfg settings $ \serverPort _chan -> do currentTime <- getSystemTime
+ test/InterfaceAPIOptimizationSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module InterfaceAPIOptimizationSpec+ ( interfaceAPIOptimizationSpecs+ , main+ ) where++import qualified Data.IORef as IORef++import Relude hiding ( readFile )++import Test.Hspec++import Utils ( firstJustM )++main :: IO ()+main = hspec interfaceAPIOptimizationSpecs++interfaceAPIOptimizationSpecs :: Spec+interfaceAPIOptimizationSpecs = describe "Interface.API optimization" $ do+ it "stops after the first Just" $ do+ visitedRef <- IORef.newIORef ([] :: [ Text ])+ let visit label = do+ IORef.modifyIORef' visitedRef (<> [ label ])+ pure $ if label == "hit-2" then Just label else Nothing++ result <- firstJustM visit [ "miss-1", "hit-2", "miss-3" ]+ visited <- IORef.readIORef visitedRef++ result `shouldBe` Just "hit-2"+ visited `shouldBe` [ "miss-1", "hit-2" ]++ it "returns Nothing after visiting every candidate when all fail" $ do+ visitedRef <- IORef.newIORef ([] :: [ Text ])+ let visit label = do+ IORef.modifyIORef' visitedRef (<> [ label ])+ pure Nothing++ result <- firstJustM visit [ "miss-1", "miss-2", "miss-3" ]+ visited <- IORef.readIORef visitedRef++ result `shouldBe` (Nothing :: Maybe Text)+ visited `shouldBe` [ "miss-1", "miss-2", "miss-3" ]++ it "preserves left-to-right evaluation order" $ do+ visitedRef <- IORef.newIORef ([] :: [ Text ])+ let visit label = do+ IORef.modifyIORef' visitedRef (<> [ label ])+ pure $ if label == "hit-3" then Just label else Nothing++ _ <- firstJustM visit [ "miss-1", "miss-2", "hit-3", "miss-4" ]+ visited <- IORef.readIORef visitedRef++ visited `shouldBe` [ "miss-1", "miss-2", "hit-3" ]
test/MockRPC.hs view
@@ -31,6 +31,8 @@ import Relude hiding ( newEmptyMVar, putMVar, takeMVar ) +import Utils ( hash )+ -- | Configuration for mock RPC server behavior data MockRPCConfig = MockRPCConfig@@ -43,6 +45,7 @@ , mockClientSettingsResponse :: ByteString -- ^ Response for client_settings , mockFileContent :: ByteString -- ^ Content for file downloads , mockPort :: Int -- ^ Port to run mock server on+ , mockClientKey :: ByteString -- ^ Key OK replies are signed with (1.6.6 RPC) } -- | Default mock configuration with valid responses@@ -65,6 +68,7 @@ , mockClientSettingsResponse = BS.unlines [ "OK", "host=127.0.0.1", "port=8080" ] , mockFileContent = "TEST_FILE_CONTENT" , mockPort = 19800+ , mockClientKey = "test-secret-key-12345" } -- | Mock RPC application@@ -76,8 +80,8 @@ case ( path, act ) of -- RPC endpoint- ( "/15/rpc", Just action ) -> handleRPCAction config action respond- ( "/15/dl", _ ) -> handleDownload config respond+ ( "/16/rpc", Just action ) -> handleRPCAction config action respond+ ( "/file", _ ) -> handleDownload config respond _ -> respond $ notFoundResponse -- | Handle RPC actions based on the 'act' parameter@@ -85,26 +89,36 @@ -> ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleRPCAction config action respond = case action of- "server_stat" -> respond $ okResponse $ mockServerStatResponse config- "client_login" -> respond $ okResponse $ mockClientLoginResponse config- "still_alive" -> respond $ okResponse $ mockStillAliveResponse config- "client_start" -> respond $ okResponse $ mockClientStartResponse config- "client_stop" -> respond $ okResponse $ mockClientStopResponse config- "get_cert" -> respond $ okResponse $ mockGetCertResponse config- "client_settings" -> respond $ okResponse $ mockClientSettingsResponse config- "get_blacklist" -> respond $ okResponse "OK" -- Empty blacklist- "dlfetch" -> respond $ okResponse "OK" -- No download URLs- "dlfails" -> respond $ okResponse "OK" -- Acknowledge failures- "srfetch" -> respond- $ okResponse- $ "OK\nhttp://localhost:" <> encodeUtf8 (show (mockPort config) :: Text) <> "/15/dl"- _ -> respond $ okResponse $ "FAIL\nUnknown action: " <> action+handleRPCAction config action respond = respond $ okResponse $ case action of+ "get_cert" -> mockGetCertResponse config -- the raw PKCS#12 file, never signed+ "server_stat" -> sign $ mockServerStatResponse config+ "client_login" -> sign $ mockClientLoginResponse config+ "still_alive" -> sign $ mockStillAliveResponse config+ "client_start" -> sign $ mockClientStartResponse config+ "client_stop" -> sign $ mockClientStopResponse config+ "client_settings" -> sign $ mockClientSettingsResponse config+ "get_blacklist" -> sign "OK" -- Empty blacklist+ "dlfetch" -> sign "OK" -- No download URLs+ "dlfails" -> sign "OK" -- Acknowledge failures+ "srfetch" -> sign+ $ "OK\nhttp://localhost:" <> encodeUtf8 (show (mockPort config) :: Text) <> "/file"+ _ -> "FAIL\nUnknown action: " <> action+ where+ -- the 1.6.6 server signs every OK reply with the client key+ sign body = case BS.lines body of+ "OK" : rest -> BS.unlines+ (("OK-1-" <> hash ("1-" <> mockClientKey config <> foldMap ("\n" <>) rest)) : rest)+ _ -> body -- | Handle download endpoint handleDownload :: MockRPCConfig -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived-handleDownload config respond = respond $ okResponse (mockFileContent config)+handleDownload config respond+ = respond+ $ Wai.responseLBS+ HTTP.status200+ [ ( "Content-Length", show (BS.length (mockFileContent config)) ) ] -- image servers always send it+ (LBS.fromStrict (mockFileContent config)) -- | Create a 200 OK response with given body okResponse :: ByteString -> Wai.Response
test/R2Spec.hs view
@@ -13,16 +13,24 @@ import Polysemy import Polysemy.Error ( Error, runError ) import Polysemy.KVStore ( KVStore, lookupKV, updateKV )+import Polysemy.Reader ( Reader, runReader ) import Storage.R2 ( R2Connection(..), mkR2Connection, runCacheR2 ) -import Relude hiding ( Reader )+import Relude hiding ( Reader, runReader ) import System.Environment ( setEnv ) import Test.Hspec -import Types ( FileURI, R2Config(..), RPCError, parseFileURI )+import Types ( ClientConfig+ , FileURI+ , R2Config(..)+ , RPCError+ , StorageResult(..)+ , defaultClientConfig+ , parseFileURI+ ) -- | R2 test configuration testR2Config :: R2Config@@ -51,21 +59,22 @@ -- | Run a program with R2 cache effect (silent logging) runWithR2Silent :: R2Connection - -> Sem '[KVStore FileURI FileRecord, Log Message, Error RPCError, Embed IO] a + -> Sem '[KVStore FileURI StorageResult, Log Message, Reader ClientConfig, Error RPCError, Embed IO] a -> IO (Either RPCError a) runWithR2Silent conn program = runM . runError @RPCError+ . runReader defaultClientConfig . runLogAction @IO @Message silentLogAction . runCacheR2 conn $ program -- | Lookup with explicit type-lookupFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Sem r (Maybe FileRecord)+lookupFile :: Member (KVStore FileURI StorageResult) r => FileURI -> Sem r (Maybe StorageResult) lookupFile = lookupKV -- | Update with explicit type-updateFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Maybe FileRecord -> Sem r ()+updateFile :: Member (KVStore FileURI StorageResult) r => FileURI -> Maybe StorageResult -> Sem r () updateFile = updateKV r2Specs :: Spec@@ -93,19 +102,20 @@ describe "runCacheR2" $ do xit "should store a file record (PUT)" $ \conn -> do- result <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+ result <- runWithR2Silent conn $ updateFile sampleURI (Just $ Record sampleRecord) result `shouldBe` Right () xit "should retrieve a stored file record (GET)" $ \conn -> do -- First store- _ <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+ _ <- runWithR2Silent conn $ updateFile sampleURI (Just $ Record sampleRecord) -- Then retrieve result <- runWithR2Silent conn $ lookupFile sampleURI case result of Left err -> expectationFailure $ "R2 error: " <> show err Right Nothing -> expectationFailure "Expected file record but got Nothing"- Right (Just record) -> do+ Right (Just (Record record)) -> do fileRecordBytes record `shouldBe` fileRecordBytes sampleRecord+ Right (Just (Redirect _)) -> expectationFailure "Expected cached record but got redirect" it "should return Nothing for non-existent file" $ \conn -> do let nonExistentURI = parseFileURI "nonexistent999-1024-800-600-jpg"@@ -117,7 +127,7 @@ xit "should delete a file record (DELETE)" $ \conn -> do -- Store first- _ <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+ _ <- runWithR2Silent conn $ updateFile sampleURI (Just $ Record sampleRecord) -- Delete deleteResult <- runWithR2Silent conn $ updateFile sampleURI Nothing deleteResult `shouldBe` Right ()
test/Spec.hs view
@@ -7,10 +7,12 @@ import Storage.Database ( FileRecord(..), runCachePure ) -import FilesystemSpec ( filesystemSpecs )-import Integration ( integrationSpecs )+import FileURIRenderSpec ( fileURIRenderSpecs )+import FilesystemSpec ( filesystemSpecs )+import Integration ( integrationSpecs )+import InterfaceAPIOptimizationSpec ( interfaceAPIOptimizationSpecs ) -import R2Spec ( r2Specs )+import R2Spec ( r2Specs ) import Polysemy import Polysemy.KVStore ( KVStore, lookupKV, updateKV )@@ -24,6 +26,8 @@ main :: IO () main = hspec $ do cacheSpecs+ interfaceAPIOptimizationSpecs+ fileURIRenderSpecs integrationSpecs r2Specs filesystemSpecs
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/ASN1/Generate.hs view
@@ -0,0 +1,147 @@+-- |+-- Module : Crypto.Store.ASN1.Generate+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Generating ASN.1+module Crypto.Store.ASN1.Generate+ ( ASN1Stream+ , ASN1Elem()+ , ASN1P()+ , ASN1PS+ , asn1Container+ , gNull+ , gIntVal+ , gOID+ , gASN1String+ , gBMPString+ , gOctetString+ , gBitString+ , gASN1Time+ , gMany+ , gEncoded+ , optASN1S+ , encodeASN1S+ ) where++import Data.ASN1.BinaryEncoding+import Data.ASN1.BinaryEncoding.Raw+import Data.ASN1.BitArray+import Data.ASN1.Encoding+import Data.ASN1.OID+import Data.ASN1.Types+import qualified Data.ByteArray as B+import Data.ByteString (ByteString)++import Time.Types (DateTime, TimezoneOffset)++-- | A stream of ASN.1 elements.+type ASN1Stream e = [e] -> [e]++-- | Elements in an ASN.1 stream.+class ASN1Elem e where+ -- | Create a container from an inner ASN.1 stream.+ asn1Container :: ASN1ConstructionType -> ASN1Stream e -> ASN1Stream e+ -- | Generate a list of ASN.1 elements.+ gMany :: [ASN1] -> ASN1Stream e+ -- | Generate one ASN.1 element.+ gOne :: ASN1 -> ASN1Stream e++instance ASN1Elem ASN1 where+ asn1Container ty f = (Start ty :) . f . (End ty :)+ gMany = (++)+ gOne = (:)++-- | Extend the 'ASN1' type to be able to encode to ASN.1 even when some parts+-- of the stream have already been encoded.+data ASN1P+ = ASN1Prim [ASN1]+ -- ^ Primitive elements (or constructed types that are fully terminated)+ | ASN1Container !ASN1ConstructionType [ASN1P]+ -- ^ Constructed type with inner structure kept+ | ASN1Encoded !ByteString+ -- ^ A part which has already been encoded++instance ASN1Elem ASN1P where+ asn1Container ty f = (ASN1Container ty (f []) :)+ gMany asn1 = (ASN1Prim asn1 :)+ gOne = gMany . (:[])++-- | Prepend a list of 'ASN1P'.+type ASN1PS = ASN1Stream ASN1P++-- | Encode to ASN.1 a list of 'ASN1P' elements. Outer encoding will be DER,+-- but partially encoded inner 'ASN1Encoded' elements many have any encoding.+pEncode :: [ASN1P] -> ByteString+pEncode x = let (_, f) = run x in f B.empty+ where+ run [] = (0, id)+ run (ASN1Prim asn1 : as) = (B.length p + r, B.append p . ps)+ where p = encodeASN1' DER asn1+ (r, ps) = run as+ run (ASN1Encoded p : as) = (B.length p + r, B.append p . ps)+ where (r, ps) = run as+ run (ASN1Container ty children : as) =+ (B.length header + l + r, B.append header . p . ps)+ where (l, p) = run children+ (r, ps) = run as+ header = toByteString [Header $ ASN1Header cl tg True $ makeLen l]+ (cl, tg) =+ case ty of+ Container tyClass tyTag -> (tyClass, tyTag)+ Sequence -> (Universal, 0x10)+ Set -> (Universal, 0x11)++ makeLen len+ | len < 0x80 = LenShort len+ | otherwise = LenLong (nbBytes len) len+ nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1++-- | Generate a 'Null' ASN.1 element.+gNull :: ASN1Elem e => ASN1Stream e+gNull = gOne Null++-- | Generate an 'IntVal' ASN.1 element.+gIntVal :: ASN1Elem e => Integer -> ASN1Stream e+gIntVal = gOne . IntVal++-- | Generate an 'OID' ASN.1 element.+gOID :: ASN1Elem e => OID -> ASN1Stream e+gOID = gOne . OID++-- | Generate an 'ASN1String' ASN.1 element.+gASN1String :: ASN1Elem e => ASN1CharacterString -> ASN1Stream e+gASN1String = gOne . ASN1String++-- | Generate an @BMPString@ ASN.1 element.+gBMPString :: ASN1Elem e => String -> ASN1Stream e+gBMPString = gASN1String . asn1CharacterString BMP++-- | Generate an 'OctetString' ASN.1 element.+gOctetString :: ASN1Elem e => ByteString -> ASN1Stream e+gOctetString = gOne . OctetString++-- | Generate a 'BitString' ASN.1 element.+gBitString :: ASN1Elem e => BitArray -> ASN1Stream e+gBitString = gOne . BitString++-- | Generate an 'ASN1Time' ASN.1 element.+gASN1Time :: ASN1Elem e+ => ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ASN1Stream e+gASN1Time a b c = gOne (ASN1Time a b c)++-- | Generate ASN.1 for an optional value.+optASN1S :: Maybe a -> (a -> ASN1Stream e) -> ASN1Stream e+optASN1S Nothing _ = id+optASN1S (Just val) fn = fn val++-- | Generate ASN.1 for a part of the stream which is already encoded.+gEncoded :: ByteString -> ASN1PS+gEncoded = (:) . ASN1Encoded++-- | Encode the ASN.1 stream to DER format (except for inner parts that are+-- already encoded and may use another format).+encodeASN1S :: ASN1PS -> ByteString+encodeASN1S asn1 = pEncode (asn1 [])
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/ASN1/Parse.hs view
@@ -0,0 +1,215 @@+-- |+-- Module : Crypto.Store.ASN1.Parse+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Parser combinators for ASN.1 stream. Similar to "Data.ASN1.Parse" but+-- with the following additions:+--+-- * Parsed stream is annotated, i.e. parser input is @('ASN1', e)@ instead of+-- @'ASN1'@. Main motivation is to allow to parse a sequence of 'ASN1Repr'+-- and hold the exact binary content that has been parsed. As consequence,+-- no @getObject@ function is provided. Function 'withAnnotations' runs+-- a parser and returns all annotations consumed in a monoid concatenation.+--+-- * The parser implements 'Alternative' and 'MonadPlus'.+--+-- * The 'fail' function returns a parse error so that pattern matching makes+-- monadic parsing code easier to write.+{-# LANGUAGE CPP #-}+module Crypto.Store.ASN1.Parse+ ( ParseASN1+ -- * run+ , runParseASN1State+ , runParseASN1State_+ , runParseASN1+ , runParseASN1_+ , throwParseError+ -- * combinators+ , onNextContainer+ , onNextContainerMaybe+ , getNextContainer+ , getNextContainerMaybe+ , getNext+ , getNextMaybe+ , hasNext+ , getMany+ , withAnnotations+ ) where++import Data.ASN1.Types+import Data.Monoid+import Control.Applicative+import Control.Arrow (first)+import Control.Monad (MonadPlus(..), liftM2)+#if !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail as Fail+#endif++data State e = State [(ASN1, e)] !e++-- | ASN1 parse monad+newtype ParseASN1 e a = P { runP :: State e -> Either String (a, State e) }++instance Functor (ParseASN1 e) where+ fmap f m = P (fmap (first f) . runP m)+instance Applicative (ParseASN1 e) where+ pure a = P $ \s -> Right (a, s)+ (<*>) mf ma = P $ \s ->+ case runP mf s of+ Left err -> Left err+ Right (f, s2) ->+ case runP ma s2 of+ Left err -> Left err+ Right (a, s3) -> Right (f a, s3)+instance Alternative (ParseASN1 e) where+ empty = throwParseError "empty"+ (<|>) = mplus+instance Monad (ParseASN1 e) where+ return = pure+ (>>=) m1 m2 = P $ \s ->+ case runP m1 s of+ Left err -> Left err+ Right (a, s2) -> runP (m2 a) s2+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif+instance MonadFail (ParseASN1 e) where+ fail = throwParseError+instance MonadPlus (ParseASN1 e) where+ mzero = throwParseError "mzero"+ mplus m1 m2 = P $ \s ->+ case runP m1 s of+ Left _ -> runP m2 s+ success -> success++get :: ParseASN1 e (State e)+get = P $ \stream -> Right (stream, stream)++put :: State e -> ParseASN1 e ()+put stream = P $ \_ -> Right ((), stream)++-- | throw a parse error+throwParseError :: String -> ParseASN1 e a+throwParseError s = P $ \_ -> Left s++wrap :: ASN1 -> (ASN1, ())+wrap a = (a, ())++unwrap :: (ASN1, ()) -> ASN1+unwrap (a, ()) = a++-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.+runParseASN1State :: ParseASN1 () a -> [ASN1] -> Either String (a, [ASN1])+runParseASN1State f a = do+ (a', list) <- runParseASN1State_ f (map wrap a)+ return (a', map unwrap list)++-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.+runParseASN1State_ :: Monoid e => ParseASN1 e a -> [(ASN1, e)] -> Either String (a, [(ASN1, e)])+runParseASN1State_ f a = do+ (r, State a' _) <- runP f (State a mempty)+ return (r, a')++-- | run the parse monad over a stream and returns the result.+--+-- If there's still some asn1 object in the state after calling f,+-- an error will be raised.+runParseASN1 :: ParseASN1 () a -> [ASN1] -> Either String a+runParseASN1 f s = runParseASN1_ f (map wrap s)++-- | run the parse monad over a stream and returns the result.+--+-- If there's still some asn1 object in the state after calling f,+-- an error will be raised.+runParseASN1_ :: Monoid e => ParseASN1 e a -> [(ASN1, e)] -> Either String a+runParseASN1_ f s =+ case runP f (State s mempty) of+ Left err -> Left err+ Right (o, State [] _) -> Right o+ Right (_, State er _) ->+ Left ("runParseASN1_: remaining state " ++ show (map fst er))++-- | get next element from the stream+getNext :: Monoid e => ParseASN1 e ASN1+getNext = do+ list <- get+ case list of+ State [] _ -> throwParseError "empty"+ State ((h,e):l) es -> put (State l (es <> e)) >> return h++-- | get many elements until there's nothing left+getMany :: ParseASN1 e a -> ParseASN1 e [a]+getMany getOne = do+ next <- hasNext+ if next+ then liftM2 (:) getOne (getMany getOne)+ else return []++-- | get next element from the stream maybe+getNextMaybe :: Monoid e => (ASN1 -> Maybe a) -> ParseASN1 e (Maybe a)+getNextMaybe f = do+ list <- get+ case list of+ State [] _ -> return Nothing+ State ((h,e):l) es -> let r = f h+ in do case r of+ Nothing -> put list+ Just _ -> put (State l (es <> e))+ return r++-- | get next container of specified type and return all its elements+getNextContainer :: Monoid e => ASN1ConstructionType -> ParseASN1 e [(ASN1, e)]+getNextContainer ty = do+ list <- get+ case list of+ State [] _ -> throwParseError "empty"+ State ((h,e):l) es | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 (State l (es <> e))+ put l2 >> return l1+ | otherwise -> throwParseError "not an expected container"+++-- | run a function of the next elements of a container of specified type+onNextContainer :: Monoid e => ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a+onNextContainer ty f = getNextContainer ty >>= either throwParseError return . runParseASN1_ f++-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists.+getNextContainerMaybe :: Monoid e => ASN1ConstructionType -> ParseASN1 e (Maybe [(ASN1, e)])+getNextContainerMaybe ty = do+ list <- get+ case list of+ State [] _ -> return Nothing+ State ((h,e):l) es | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 (State l (es <> e))+ put l2 >> return (Just l1)+ | otherwise -> return Nothing++-- | just like onNextContainer, except it doesn't throw an error if the container doesn't exists.+onNextContainerMaybe :: Monoid e => ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)+onNextContainerMaybe ty f = do+ n <- getNextContainerMaybe ty+ case n of+ Just l -> either throwParseError (return . Just) $ runParseASN1_ f l+ Nothing -> return Nothing++-- | returns if there's more elements in the stream.+hasNext :: ParseASN1 e Bool+hasNext = do State l _ <- get; return . not . null $ l++-- | run a parser and return its result as well as all annotations that were used+withAnnotations :: Monoid e => ParseASN1 e a -> ParseASN1 e (a, e)+withAnnotations f = do+ State l es <- get+ case runP f (State l mempty) of+ Left err -> throwParseError err+ Right (a, State l' es') -> do put (State l' (es <> es'))+ return (a, es')++getConstructedEnd :: Monoid e => Int -> State e -> ([(ASN1, e)], State e)+getConstructedEnd _ xs@(State [] _) = ([], xs)+getConstructedEnd i (State (x@(Start _, e):xs) es) = let (yz, zs) = getConstructedEnd (i+1) (State xs (es <> e)) in (x:yz, zs)+getConstructedEnd i (State (x@(End _, e):xs) es)+ | i == 0 = ([], State xs (es <> e))+ | otherwise = let (ys, zs) = getConstructedEnd (i-1) (State xs (es <> e)) in (x:ys, zs)+getConstructedEnd i (State (x@(_, e):xs) es) = let (ys, zs) = getConstructedEnd i (State xs (es <> e)) in (x:ys, zs)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS.hs view
@@ -0,0 +1,499 @@+-- |+-- Module : Crypto.Store.CMS+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Cryptographic Message Syntax+--+-- * <https://tools.ietf.org/html/rfc5652 RFC 5652>: Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc3370 RFC 3370>: Cryptographic Message Syntax (CMS) Algorithms+-- * <https://tools.ietf.org/html/rfc3560 RFC 3560>: Use of the RSAES-OAEP Key Transport Algorithm in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc4056 RFC 4056>: Use of the RSASSA-PSS Signature Algorithm in Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc3565 RFC 3565>: Use of the Advanced Encryption Standard (AES) Encryption Algorithm in Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc5753 RFC 5753>: Use of Elliptic Curve Cryptography (ECC) Algorithms in Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc5754 RFC 5754>: Using SHA2 Algorithms with Cryptographic Message Syntax+-- * <https://tools.ietf.org/html/rfc3211 RFC 3211>: Password-based Encryption for CMS+-- * <https://tools.ietf.org/html/rfc5083 RFC 5083>: Cryptographic Message Syntax (CMS) Authenticated-Enveloped-Data Content Type+-- * <https://tools.ietf.org/html/rfc5084 RFC 5084>: Using AES-CCM and AES-GCM Authenticated Encryption in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc6476 RFC 6476>: Using Message Authentication Code (MAC) Encryption in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc8103 RFC 8103>: Using ChaCha20-Poly1305 Authenticated Encryption in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc8418 RFC 8418>: Use of the Elliptic Curve Diffie-Hellman Key Agreement Algorithm with X25519 and X448 in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc8419 RFC 8419>: Use of Edwards-Curve Digital Signature Algorithm (EdDSA) Signatures in the Cryptographic Message Syntax (CMS)+-- * <https://tools.ietf.org/html/rfc8702 RFC 8702>: Use of the SHAKE One-Way Hash Functions in the Cryptographic Message Syntax (CMS)+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS+ ( ContentType(..)+ , ContentInfo(..)+ , getContentType+ -- * Reading and writing PEM files+ , module Crypto.Store.CMS.PEM+ -- * Content encapsulation+ , Encap(..)+ , fromEncap+ , Encapsulates+ , isAttached+ , fromAttached+ , toAttachedCI+ , isDetached+ , fromDetached+ , toDetachedCI+ -- * Signed data+ , SignatureValue+ , SignatureAlg(..)+ , EncapsulatedContent+ , SignedData(..)+ , ProducerOfSI+ , ConsumerOfSI+ , signData+ , verifySignedData+ -- ** Signer information+ , SignerInfo(..)+ , SignerIdentifier(..)+ , IssuerAndSerialNumber(..)+ , certSigner+ , withPublicKey+ , withSignerKey+ , withSignerCertificate+ -- * Enveloped data+ , EncryptedKey+ , KeyEncryptionParams(..)+ , KeyTransportParams(..)+ , KeyAgreementParams(..)+ , KeyAgreementKDF(..)+ , RecipientInfo(..)+ , EnvelopedData(..)+ , ProducerOfRI+ , ConsumerOfRI+ , envelopData+ , openEnvelopedData+ -- ** Key Transport recipients+ , KTRecipientInfo(..)+ , RecipientIdentifier(..)+ , forKeyTransRecipient+ , withRecipientKeyTrans+ -- ** Key Agreement recipients+ , KARecipientInfo(..)+ , OriginatorIdentifierOrKey(..)+ , OriginatorPublicKey+ , RecipientEncryptedKey(..)+ , KeyAgreeRecipientIdentifier(..)+ , UserKeyingMaterial+ , forKeyAgreeRecipient+ , withRecipientKeyAgree+ -- ** Key Encryption Key recipients+ , KEKRecipientInfo(..)+ , KeyIdentifier(..)+ , OtherKeyAttribute(..)+ , KeyEncryptionKey+ , forKeyRecipient+ , withRecipientKey+ -- ** Password recipients+ , PasswordRecipientInfo(..)+ , forPasswordRecipient+ , withRecipientPassword+ -- * Digested data+ , DigestProxy(..)+ , DigestAlgorithm(..)+ , DigestedData(..)+ , digestData+ , digestVerify+ -- * Encrypted data+ , ContentEncryptionKey+ , ContentEncryptionCipher(..)+ , ContentEncryptionAlg(..)+ , ContentEncryptionParams+ , EncryptedContent+ , EncryptedData(..)+ , generateEncryptionParams+ , generateRC2EncryptionParams+ , getContentEncryptionAlg+ , encryptData+ , decryptData+ -- * Authenticated data+ , AuthenticationKey+ , MACAlgorithm(..)+ , MessageAuthenticationCode+ , AuthenticatedData(..)+ , generateAuthenticatedData+ , verifyAuthenticatedData+ -- * Authenticated-enveloped data+ , AuthContentEncryptionAlg(..)+ , AuthContentEncryptionParams+ , AuthEnvelopedData(..)+ , generateAuthEnc128Params+ , generateAuthEnc256Params+ , generateChaChaPoly1305Params+ , generateCCMParams+ , generateGCMParams+ , authEnvelopData+ , openAuthEnvelopedData+ -- * Key derivation+ , Salt+ , generateSalt+ , KeyDerivationFunc(..)+ , PBKDF2_PRF(..)+ -- * Secret-key algorithms+ , HasKeySize(..)+ , generateKey+ -- * RSA padding modes+ , MaskGenerationFunc(..)+ , OAEPParams(..)+ , PSSParams(..)+ -- * CMS attributes+ , Attribute(..)+ , findAttribute+ , setAttribute+ , filterAttributes+ -- * CMS standard attributes+ , getSigningTimeAttr+ , setSigningTimeAttr+ , setSigningTimeAttrCurrent+ -- * Originator information+ , OriginatorInfo(..)+ , CertificateChoice(..)+ , OtherCertificateFormat(..)+ , RevocationInfoChoice(..)+ , OtherRevocationInfoFormat(..)+ -- * ASN.1 representation+ , ASN1ObjectExact+ ) where++import Data.ASN1.BinaryEncoding+import Data.ASN1.Encoding+import Data.ByteString (ByteString)+import Data.Maybe (isJust)+import Data.List (nub)++import Crypto.Hash++import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Authenticated+import Crypto.Store.CMS.AuthEnveloped+import Crypto.Store.CMS.Digested+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.OriginatorInfo+import Crypto.Store.CMS.Info+import Crypto.Store.CMS.PEM+import Crypto.Store.CMS.Signed+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util+import Crypto.Store.Error+import Crypto.Store.Util+++-- DigestedData++-- | Add a digested-data layer on the specified content info.+digestData :: DigestAlgorithm -> ContentInfo -> DigestedData EncapsulatedContent+digestData (DigestAlgorithm alg) ci = dd+ where dd = DigestedData+ { ddDigestAlgorithm = alg+ , ddContentType = getContentType ci+ , ddEncapsulatedContent = encapsulate ci+ , ddDigest = hash (encapsulate ci)+ }++-- | Return the inner content info but only if the digest is valid.+digestVerify :: DigestedData EncapsulatedContent -> Either StoreError ContentInfo+digestVerify DigestedData{..}+ | not acceptable = Left (InvalidParameter "Digest too weak")+ | ddDigest == hash ddEncapsulatedContent =+ decapsulate ddContentType ddEncapsulatedContent+ | otherwise = Left DigestMismatch+ where acceptable = securityAcceptable (DigestAlgorithm ddDigestAlgorithm)+++-- EncryptedData++-- | Add an encrypted-data layer on the specified content info. The content is+-- encrypted with specified key and algorithm.+--+-- Some optional attributes can be added but will not be encrypted.+encryptData :: ContentEncryptionKey+ -> ContentEncryptionParams+ -> [Attribute]+ -> ContentInfo+ -> Either StoreError (EncryptedData EncryptedContent)+encryptData key params attrs ci =+ build <$> contentEncrypt key params (encapsulate ci)+ where+ build ec = EncryptedData+ { edContentType = getContentType ci+ , edContentEncryptionParams = params+ , edEncryptedContent = ec+ , edUnprotectedAttrs = attrs+ }++-- | Decrypt an encrypted content info using the specified key.+decryptData :: ContentEncryptionKey+ -> EncryptedData EncryptedContent+ -> Either StoreError ContentInfo+decryptData key EncryptedData{..} = do+ decrypted <- contentDecrypt key edContentEncryptionParams edEncryptedContent+ decapsulate edContentType decrypted+++-- EnvelopedData++-- | Add an enveloped-data layer on the specified content info. The content is+-- encrypted with specified key and algorithm. The key is then processed by+-- one or several 'ProducerOfRI' functions to create recipient info elements.+--+-- Some optional attributes can be added but will not be encrypted.+envelopData :: Applicative f+ => OriginatorInfo+ -> ContentEncryptionKey+ -> ContentEncryptionParams+ -> [ProducerOfRI f]+ -> [Attribute]+ -> ContentInfo+ -> f (Either StoreError (EnvelopedData EncryptedContent))+envelopData oinfo key params envFns attrs ci =+ f <$> (sequence <$> traverse ($ key) envFns)+ where+ ebs = contentEncrypt key params (encapsulate ci)+ f ris = build <$> ebs <*> ris+ build bs ris = EnvelopedData+ { evOriginatorInfo = oinfo+ , evRecipientInfos = ris+ , evContentType = getContentType ci+ , evContentEncryptionParams = params+ , evEncryptedContent = bs+ , evUnprotectedAttrs = attrs+ }++-- | Recover an enveloped content info using the specified 'ConsumerOfRI'+-- function.+openEnvelopedData :: Monad m+ => ConsumerOfRI m+ -> EnvelopedData EncryptedContent+ -> m (Either StoreError ContentInfo)+openEnvelopedData devFn EnvelopedData{..} = do+ r <- riAttempts (map (fmap (>>= decr) . devFn) evRecipientInfos)+ return (r >>= decapsulate ct)+ where+ ct = evContentType+ params = evContentEncryptionParams+ decr k = contentDecrypt k params evEncryptedContent+++-- AuthenticatedData++-- | Key used for authentication.+type AuthenticationKey = ContentEncryptionKey++-- | Add an authenticated-data layer on the specified content info. The content+-- is MACed with the specified key and algorithms. The key is then processed by+-- one or several 'ProducerOfRI' functions to create recipient info elements.+--+-- Two lists of optional attributes can be provided. The attributes will be+-- part of message authentication when provided in the first list.+generateAuthenticatedData :: Applicative f+ => OriginatorInfo+ -> AuthenticationKey+ -> MACAlgorithm+ -> Maybe DigestAlgorithm+ -> [ProducerOfRI f]+ -> [Attribute]+ -> [Attribute]+ -> ContentInfo+ -> f (Either StoreError (AuthenticatedData EncapsulatedContent))+generateAuthenticatedData oinfo key macAlg digAlg envFns aAttrs uAttrs ci =+ f <$> (sequence <$> traverse ($ key) envFns)+ where+ msg = encapsulate ci+ ct = getContentType ci++ (aAttrs', input) =+ case digAlg of+ Nothing -> (aAttrs, msg)+ Just dig ->+ let md = digest dig msg+ l = setContentTypeAttr ct $ setMessageDigestAttr md aAttrs+ in (l, encodeAuthAttrs l)++ ebs = mac macAlg key input+ f ris = build ebs <$> ris+ build authTag ris = AuthenticatedData+ { adOriginatorInfo = oinfo+ , adRecipientInfos = ris+ , adMACAlgorithm = macAlg+ , adDigestAlgorithm = digAlg+ , adContentType = getContentType ci+ , adEncapsulatedContent = encapsulate ci+ , adAuthAttrs = aAttrs'+ , adMAC = authTag+ , adUnauthAttrs = uAttrs+ }++-- | Verify the integrity of an authenticated content info using the specified+-- 'ConsumerOfRI' function. The inner content info is returned only if the MAC+-- could be verified.+verifyAuthenticatedData :: Monad m+ => ConsumerOfRI m+ -> AuthenticatedData EncapsulatedContent+ -> m (Either StoreError ContentInfo)+verifyAuthenticatedData devFn AuthenticatedData{..} =+ riAttempts (map (fmap (>>= unwrap) . devFn) adRecipientInfos)+ where+ msg = adEncapsulatedContent+ ct = adContentType++ noAttr = null adAuthAttrs+ mdMatch = case adDigestAlgorithm of+ Nothing -> False+ Just dig -> mdAttr == Just (digest dig msg)+ mdAccept = maybe True securityAcceptable adDigestAlgorithm+ macAccept = securityAcceptable adMACAlgorithm+ attrMatch = ctAttr == Just ct && mdMatch+ mdAttr = getMessageDigestAttr adAuthAttrs+ ctAttr = getContentTypeAttr adAuthAttrs+ input = if noAttr then msg else encodeAuthAttrs adAuthAttrs++ unwrap k+ | isJust adDigestAlgorithm && noAttr = Left (InvalidInput "Missing auth attributes")+ | not noAttr && not attrMatch = Left (InvalidInput "Invalid auth attributes")+ | not mdAccept = Left (InvalidParameter "Digest too weak")+ | not macAccept = Left (InvalidParameter "MAC too weak")+ | adMAC /= mac adMACAlgorithm k input = Left BadContentMAC+ | otherwise = decapsulate adContentType adEncapsulatedContent+++-- AuthEnvelopedData++-- | Add an authenticated-enveloped-data layer on the specified content info.+-- The content is encrypted with specified key and algorithm. The key is then+-- processed by one or several 'ProducerOfRI' functions to create recipient info+-- elements.+--+-- Some attributes can be added but will not be encrypted. The attributes+-- will be part of message authentication when provided in the first list.+authEnvelopData :: Applicative f+ => OriginatorInfo+ -> ContentEncryptionKey+ -> AuthContentEncryptionParams+ -> [ProducerOfRI f]+ -> [Attribute]+ -> [Attribute]+ -> ContentInfo+ -> f (Either StoreError (AuthEnvelopedData EncryptedContent))+authEnvelopData oinfo key params envFns aAttrs uAttrs ci =+ f <$> (sequence <$> traverse ($ key) envFns)+ where+ raw = encodeASN1Object params+ aad = encodeAuthAttrs aAttrs+ ebs = authContentEncrypt key params raw aad (encapsulate ci)+ f ris = build <$> ebs <*> ris+ build (authTag, bs) ris = AuthEnvelopedData+ { aeOriginatorInfo = oinfo+ , aeRecipientInfos = ris+ , aeContentType = getContentType ci+ , aeContentEncryptionParams = ASN1ObjectExact params raw+ , aeEncryptedContent = bs+ , aeAuthAttrs = aAttrs+ , aeMAC = authTag+ , aeUnauthAttrs = uAttrs+ }++-- | Recover an authenticated-enveloped content info using the specified+-- 'ConsumerOfRI' function.+openAuthEnvelopedData :: Monad m+ => ConsumerOfRI m+ -> AuthEnvelopedData EncryptedContent+ -> m (Either StoreError ContentInfo)+openAuthEnvelopedData devFn AuthEnvelopedData{..} = do+ r <- riAttempts (map (fmap (>>= decr) . devFn) aeRecipientInfos)+ return (r >>= decapsulate ct)+ where+ ct = aeContentType+ params = exactObject aeContentEncryptionParams+ raw = exactObjectRaw aeContentEncryptionParams+ aad = encodeAuthAttrs aeAuthAttrs+ decr k = authContentDecrypt k params raw aad aeEncryptedContent aeMAC+++-- SignedData++-- | Add a signed-data layer on the specified content info. The content is+-- processed by one or several 'ProducerOfSI' functions to create signer info+-- elements.+signData :: Applicative f+ => [ProducerOfSI f] -> ContentInfo -> f (Either StoreError (SignedData EncapsulatedContent))+signData sigFns ci =+ f <$> (sequence <$> traverse (\fn -> fn ct msg) sigFns)+ where+ msg = encapsulate ci+ ct = getContentType ci+ f = fmap (build . unzip3)++ build (sis, certLists, crlLists) =+ SignedData+ { sdDigestAlgorithms = nub (map siDigestAlgorithm sis)+ , sdContentType = getContentType ci+ , sdEncapsulatedContent = encapsulate ci+ , sdCertificates = concat certLists+ , sdCRLs = concat crlLists+ , sdSignerInfos = sis+ }++-- | Verify a signed content info using the specified 'ConsumerOfSI' function.+-- Verification of at least one signer info must be successful in order to+-- return the inner content info.+verifySignedData :: Monad m+ => ConsumerOfSI m -> SignedData EncapsulatedContent -> m (Either StoreError ContentInfo)+verifySignedData verFn SignedData{..} =+ f <$> siAttemps valid sdSignerInfos+ where+ msg = sdEncapsulatedContent+ ct = sdContentType+ valid si = verFn ct msg si sdCertificates sdCRLs+ f bool = if bool then decapsulate sdContentType sdEncapsulatedContent+ else Left SignatureNotVerified+++-- Utilities++riAttempts :: Monad m => [m (Either StoreError b)] -> m (Either StoreError b)+riAttempts [] = return (Left NoRecipientInfoFound)+riAttempts [single] = single+riAttempts list = loop list+ where+ loop [] = return (Left NoRecipientInfoMatched)+ loop (x:xs) = x >>= orTail xs++ orTail xs (Left _) = loop xs+ orTail _ success = return success++siAttemps :: Monad m => (a -> m Bool) -> [a] -> m Bool+siAttemps _ [] = pure False+siAttemps f (x:xs) = f x >>= orTail+ where orTail bool = if bool then return True else siAttemps f xs++decode :: ParseASN1 [ASN1Event] a -> ByteString -> Either StoreError a+decode parser bs = vals >>= mapLeft ParseFailure . runParseASN1_ parser+ where vals = mapLeft DecodingError (decodeASN1Repr' BER bs)++-- | Encode the information for encapsulation in another content info.+encapsulate :: ContentInfo -> ByteString+encapsulate (DataCI bs) = bs+encapsulate (SignedDataCI ed) = encodeASN1Object ed+encapsulate (EnvelopedDataCI ed) = encodeASN1Object ed+encapsulate (DigestedDataCI dd) = encodeASN1Object dd+encapsulate (EncryptedDataCI ed) = encodeASN1Object ed+encapsulate (AuthenticatedDataCI ad) = encodeASN1Object ad+encapsulate (AuthEnvelopedDataCI ae) = encodeASN1Object ae++-- | Decode the information from encapsulated content.+decapsulate :: ContentType -> ByteString -> Either StoreError ContentInfo+decapsulate DataType bs = pure (DataCI bs)+decapsulate SignedDataType bs = SignedDataCI <$> decode parse bs+decapsulate EnvelopedDataType bs = EnvelopedDataCI <$> decode parse bs+decapsulate DigestedDataType bs = DigestedDataCI <$> decode parse bs+decapsulate EncryptedDataType bs = EncryptedDataCI <$> decode parse bs+decapsulate AuthenticatedDataType bs = AuthenticatedDataCI <$> decode parse bs+decapsulate AuthEnvelopedDataType bs = AuthEnvelopedDataCI <$> decode parse bs
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Algorithms.hs view
@@ -0,0 +1,2293 @@+-- |+-- Module : Crypto.Store.CMS.Algorithms+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Cryptographic Message Syntax algorithms+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module Crypto.Store.CMS.Algorithms+ ( DigestAlgorithm(..)+ , DigestProxy(..)+ , digest+ , MessageAuthenticationCode+ , MACAlgorithm(..)+ , mac+ , HasStrength+ , securityAcceptable+ , HasKeySize(..)+ , getMaximumKeySize+ , validateKeySize+ , generateKey+ , ContentEncryptionCipher(..)+ , ContentEncryptionAlg(..)+ , ContentEncryptionParams(..)+ , generateEncryptionParams+ , generateRC2EncryptionParams+ , getContentEncryptionAlg+ , proxyBlockSize+ , contentEncrypt+ , contentDecrypt+ , AuthContentEncryptionAlg(..)+ , AuthContentEncryptionParams+ , generateAuthEnc128Params+ , generateAuthEnc256Params+ , generateChaChaPoly1305Params+ , generateCCMParams+ , generateGCMParams+ , authContentEncrypt+ , authContentDecrypt+ , PBKDF2_PRF(..)+ , prf+ , Salt+ , generateSalt+ , KeyDerivationFunc(..)+ , kdfKeyLength+ , kdfDerive+ , KeyEncryptionParams(..)+ , keyEncrypt+ , keyDecrypt+ , OAEPParams(..)+ , KeyTransportParams(..)+ , transportEncrypt+ , transportDecrypt+ , KeyAgreementParams(..)+ , KeyAgreementKDF(..)+ , ECDHPair+ , ecdhGenerate+ , ecdhPublic+ , ecdhEncrypt+ , ecdhDecrypt+ , MaskGenerationFunc(..)+ , mgf+ , SignatureValue+ , PSSParams(..)+ , SignatureAlg(..)+ , signatureResolveHash+ , signatureCheckHash+ , signatureGenerate+ , signatureVerify+ ) where++import Control.Applicative+import Control.Monad (guard, when)++import Data.ASN1.BinaryEncoding+import Data.ASN1.OID+import Data.ASN1.Encoding+import Data.ASN1.Types+import Data.Bits+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as B+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.Word+import qualified Data.X509 as X509+import Data.X509.EC++import GHC.TypeLits++import qualified Crypto.Cipher.AES as Cipher+import qualified Crypto.Cipher.CAST5 as Cipher+import qualified Crypto.Cipher.Camellia as Cipher+import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305+import qualified Crypto.Cipher.DES as Cipher+import qualified Crypto.Cipher.TripleDES as Cipher+import Crypto.Cipher.Types+import Crypto.Data.Padding+import Crypto.ECC (Curve_X25519, Curve_X448, ecdh)+import Crypto.Error+import qualified Crypto.Hash as Hash+import qualified Crypto.KDF.HKDF as HKDF+import qualified Crypto.KDF.PBKDF2 as PBKDF2+import qualified Crypto.KDF.Scrypt as Scrypt+import qualified Crypto.MAC.HMAC as HMAC+import qualified Crypto.MAC.KMAC as KMAC+import qualified Crypto.MAC.Poly1305 as Poly1305+import Crypto.Number.Serialize+import qualified Crypto.PubKey.Curve25519 as X25519+import qualified Crypto.PubKey.Curve448 as X448+import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.ECC.DH as ECDH+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Types as ECC+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.MaskGenFunction as MGF+import qualified Crypto.PubKey.RSA.PSS as RSAPSS+import qualified Crypto.PubKey.RSA.OAEP as RSAOAEP+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import Crypto.Random++import Foreign.Ptr (Ptr)+import Foreign.Storable++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Util+import Crypto.Store.Cipher.RC2+import Crypto.Store.Error+import qualified Crypto.Store.KeyWrap.AES as AES_KW+import qualified Crypto.Store.KeyWrap.TripleDES as TripleDES_KW+import qualified Crypto.Store.KeyWrap.RC2 as RC2_KW+import Crypto.Store.PKCS8.EC+import Crypto.Store.Util+++-- Hash functions++-- | CMS digest proxy. Acts like 'Data.Proxy.Proxy', i.e. provides a hash+-- algorithm as type parameter. The GADT constructors map to known algorithms.+data DigestProxy hashAlg where+ -- | MD2+ MD2 :: DigestProxy Hash.MD2+ -- | MD4+ MD4 :: DigestProxy Hash.MD4+ -- | MD5+ MD5 :: DigestProxy Hash.MD5+ -- | SHA-1+ SHA1 :: DigestProxy Hash.SHA1+ -- | SHA-224+ SHA224 :: DigestProxy Hash.SHA224+ -- | SHA-256+ SHA256 :: DigestProxy Hash.SHA256+ -- | SHA-384+ SHA384 :: DigestProxy Hash.SHA384+ -- | SHA-512+ SHA512 :: DigestProxy Hash.SHA512+ -- | SHAKE128 (256 bits)+ SHAKE128_256 :: DigestProxy (Hash.SHAKE128 256)+ -- | SHAKE256 (512 bits)+ SHAKE256_512 :: DigestProxy (Hash.SHAKE256 512)+ -- | SHAKE128 (variable size)+ SHAKE128 :: KnownNat n => Proxy n -> DigestProxy (Hash.SHAKE128 n)+ -- | SHAKE256 (variable size)+ SHAKE256 :: KnownNat n => Proxy n -> DigestProxy (Hash.SHAKE256 n)+++instance Show (DigestProxy hashAlg) where+ showsPrec _ MD2 = showString "MD2"+ showsPrec _ MD4 = showString "MD4"+ showsPrec _ MD5 = showString "MD5"+ showsPrec _ SHA1 = showString "SHA1"+ showsPrec _ SHA224 = showString "SHA224"+ showsPrec _ SHA256 = showString "SHA256"+ showsPrec _ SHA384 = showString "SHA384"+ showsPrec _ SHA512 = showString "SHA512"+ showsPrec _ SHAKE128_256 = showString "SHAKE128_256"+ showsPrec _ SHAKE256_512 = showString "SHAKE256_512"+ showsPrec d (SHAKE128 p) =+ showParen (d > 10) $ showString "SHAKE128 " . showNat 11 p+ showsPrec d (SHAKE256 p) =+ showParen (d > 10) $ showString "SHAKE256 " . showNat 11 p++showNat :: KnownNat n => Int -> Proxy n -> ShowS+showNat d n = showParen (d > 0) $+ shows n . showString " :: Proxy " . shows (natVal n)++deriving instance Eq (DigestProxy hashAlg)++instance HasStrength (DigestProxy hashAlg) where+ getSecurityBits MD2 = 64+ getSecurityBits MD4 = 64+ getSecurityBits MD5 = 64+ getSecurityBits SHA1 = 80+ getSecurityBits SHA224 = 112+ getSecurityBits SHA256 = 128+ getSecurityBits SHA384 = 192+ getSecurityBits SHA512 = 256+ getSecurityBits SHAKE128_256 = 128+ getSecurityBits SHAKE256_512 = 256+ getSecurityBits (SHAKE128 a) = shakeSecurityBits 128 a+ getSecurityBits (SHAKE256 a) = shakeSecurityBits 256 a++shakeSecurityBits :: KnownNat n => Int -> proxy n -> Int+shakeSecurityBits m a = min m (fromInteger (natVal a) `div` 2)++-- | CMS digest algorithm.+data DigestAlgorithm =+ forall hashAlg . Hash.HashAlgorithm hashAlg+ => DigestAlgorithm (DigestProxy hashAlg)++instance Show DigestAlgorithm where+ show (DigestAlgorithm a) = show a++instance Eq DigestAlgorithm where+ DigestAlgorithm MD2 == DigestAlgorithm MD2 = True+ DigestAlgorithm MD4 == DigestAlgorithm MD4 = True+ DigestAlgorithm MD5 == DigestAlgorithm MD5 = True+ DigestAlgorithm SHA1 == DigestAlgorithm SHA1 = True+ DigestAlgorithm SHA224 == DigestAlgorithm SHA224 = True+ DigestAlgorithm SHA256 == DigestAlgorithm SHA256 = True+ DigestAlgorithm SHA384 == DigestAlgorithm SHA384 = True+ DigestAlgorithm SHA512 == DigestAlgorithm SHA512 = True+ DigestAlgorithm SHAKE128_256 == DigestAlgorithm SHAKE128_256 = True+ DigestAlgorithm SHAKE256_512 == DigestAlgorithm SHAKE256_512 = True+ DigestAlgorithm (SHAKE128 a) == DigestAlgorithm (SHAKE128 b) = natVal a == natVal b+ DigestAlgorithm (SHAKE256 a) == DigestAlgorithm (SHAKE256 b) = natVal a == natVal b+ _ == _ = False++instance HasStrength DigestAlgorithm where+ getSecurityBits (DigestAlgorithm a) = getSecurityBits a++data DigestType+ = Type_MD2+ | Type_MD4+ | Type_MD5+ | Type_SHA1+ | Type_SHA224+ | Type_SHA256+ | Type_SHA384+ | Type_SHA512+ | Type_SHAKE128_256+ | Type_SHAKE256_512+ | Type_SHAKE128_Len+ | Type_SHAKE256_Len++instance Enumerable DigestType where+ values = [ Type_MD2+ , Type_MD4+ , Type_MD5+ , Type_SHA1+ , Type_SHA224+ , Type_SHA256+ , Type_SHA384+ , Type_SHA512+ , Type_SHAKE128_256+ , Type_SHAKE256_512+ , Type_SHAKE128_Len+ , Type_SHAKE256_Len+ ]++instance OIDable DigestType where+ getObjectID Type_MD2 = [1,2,840,113549,2,2]+ getObjectID Type_MD4 = [1,2,840,113549,2,4]+ getObjectID Type_MD5 = [1,2,840,113549,2,5]+ getObjectID Type_SHA1 = [1,3,14,3,2,26]+ getObjectID Type_SHA224 = [2,16,840,1,101,3,4,2,4]+ getObjectID Type_SHA256 = [2,16,840,1,101,3,4,2,1]+ getObjectID Type_SHA384 = [2,16,840,1,101,3,4,2,2]+ getObjectID Type_SHA512 = [2,16,840,1,101,3,4,2,3]+ getObjectID Type_SHAKE128_256 = [2,16,840,1,101,3,4,2,11]+ getObjectID Type_SHAKE256_512 = [2,16,840,1,101,3,4,2,12]+ getObjectID Type_SHAKE128_Len = [2,16,840,1,101,3,4,2,17]+ getObjectID Type_SHAKE256_Len = [2,16,840,1,101,3,4,2,18]++instance OIDNameable DigestType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++instance AlgorithmId DigestAlgorithm where+ type AlgorithmType DigestAlgorithm = DigestType+ algorithmName _ = "digest algorithm"++ algorithmType (DigestAlgorithm MD2) = Type_MD2+ algorithmType (DigestAlgorithm MD4) = Type_MD4+ algorithmType (DigestAlgorithm MD5) = Type_MD5+ algorithmType (DigestAlgorithm SHA1) = Type_SHA1+ algorithmType (DigestAlgorithm SHA224) = Type_SHA224+ algorithmType (DigestAlgorithm SHA256) = Type_SHA256+ algorithmType (DigestAlgorithm SHA384) = Type_SHA384+ algorithmType (DigestAlgorithm SHA512) = Type_SHA512+ algorithmType (DigestAlgorithm SHAKE128_256) = Type_SHAKE128_256+ algorithmType (DigestAlgorithm SHAKE256_512) = Type_SHAKE256_512+ algorithmType (DigestAlgorithm (SHAKE128 _)) = Type_SHAKE128_Len+ algorithmType (DigestAlgorithm (SHAKE256 _)) = Type_SHAKE256_Len++ -- MD5 has NULL parameter, SHAKE128 and SHAKE256 have the bitsize as+ -- parameter, other algorithms have no parameter+ parameterASN1S (DigestAlgorithm MD5) = gNull+ parameterASN1S (DigestAlgorithm (SHAKE128 n)) = gIntVal (natVal n)+ parameterASN1S (DigestAlgorithm (SHAKE256 n)) = gIntVal (natVal n)+ parameterASN1S _ = id++ parseParameter Type_MD2 = parseDigestParam (DigestAlgorithm MD2)+ parseParameter Type_MD4 = parseDigestParam (DigestAlgorithm MD4)+ parseParameter Type_MD5 = parseDigestParam (DigestAlgorithm MD5)+ parseParameter Type_SHA1 = parseDigestParam (DigestAlgorithm SHA1)+ parseParameter Type_SHA224 = parseDigestParam (DigestAlgorithm SHA224)+ parseParameter Type_SHA256 = parseDigestParam (DigestAlgorithm SHA256)+ parseParameter Type_SHA384 = parseDigestParam (DigestAlgorithm SHA384)+ parseParameter Type_SHA512 = parseDigestParam (DigestAlgorithm SHA512)+ parseParameter Type_SHAKE128_256 = parseDigestParam (DigestAlgorithm SHAKE128_256)+ parseParameter Type_SHAKE256_512 = parseDigestParam (DigestAlgorithm SHAKE256_512)+ parseParameter Type_SHAKE128_Len = parseBitLen $+ \(SomeNat p) -> return $ DigestAlgorithm (SHAKE128 p)+ parseParameter Type_SHAKE256_Len = parseBitLen $+ \(SomeNat p) -> return $ DigestAlgorithm (SHAKE256 p)++-- | Compute the digest of a message.+digest :: ByteArrayAccess message => DigestAlgorithm -> message -> ByteString+digest (DigestAlgorithm hashAlg) message = B.convert (doHash hashAlg message)++doHash :: (Hash.HashAlgorithm hashAlg, ByteArrayAccess ba)+ => proxy hashAlg -> ba -> Hash.Digest hashAlg+doHash _ = Hash.hash++hashFromProxy :: proxy a -> a+hashFromProxy _ = undefined++parseDigestParam :: Monoid e => DigestAlgorithm -> ParseASN1 e DigestAlgorithm+parseDigestParam p = getNextMaybe nullOrNothing >> return p++parseBitLen :: Monoid e => (SomeNat -> ParseASN1 e a) -> ParseASN1 e a+parseBitLen fn = do+ IntVal n <- getNext+ case someNatVal n of+ Nothing -> throwParseError ("Invalid bit length: " ++ show n)+ Just sn -> fn sn++p256 :: Proxy 256+p256 = Proxy++p512 :: Proxy 512+p512 = Proxy+++-- Security strength++-- | Algorithms with known security strength.+class HasStrength params where+ -- | Get security strength in bits.+ --+ -- This returns the strength for which the algorithm was designed.+ -- Algorithms with weaknesses have an effective strength lower than the+ -- returned value.+ getSecurityBits :: params -> Int++-- | Whether the algorithm has acceptable security. The goal is to eliminate+-- variable-length algorithms, like SHAKE with 1-byte output, that would make+-- strength lower than the weakest fixed-length algorithm.+securityAcceptable :: HasStrength params => params -> Bool+securityAcceptable = (>= 64) . getSecurityBits+++-- Cipher-like things++-- | Algorithms that are based on a secret key. This includes ciphers but also+-- MAC algorithms.+class HasKeySize params where+ -- | Get a specification of the key sizes allowed by the algorithm.+ getKeySizeSpecifier :: params -> KeySizeSpecifier++-- | Return the maximum key size for the specified algorithm.+getMaximumKeySize :: HasKeySize params => params -> Int+getMaximumKeySize params =+ case getKeySizeSpecifier params of+ KeySizeRange _ n -> n+ KeySizeEnum l -> maximum l+ KeySizeFixed n -> n++-- | Return 'True' if the specified key size is valid for the specified+-- algorithm.+validateKeySize :: HasKeySize params => params -> Int -> Bool+validateKeySize params len =+ case getKeySizeSpecifier params of+ KeySizeRange a b -> a <= len && len <= b+ KeySizeEnum l -> len `elem` l+ KeySizeFixed n -> len == n++-- | Generate a random key suitable for the specified algorithm. This uses the+-- maximum size allowed by the parameters.+generateKey :: (HasKeySize params, MonadRandom m, ByteArray key)+ => params -> m key+generateKey params = getRandomBytes (getMaximumKeySize params)+++-- MAC++-- | Message authentication code. Equality is time constant.+type MessageAuthenticationCode = AuthTag++data MACType+ = forall hashAlg . Hash.HashAlgorithm hashAlg+ => TypeHMAC (DigestProxy hashAlg)+ | TypeKMAC_SHAKE128+ | TypeKMAC_SHAKE256++deriving instance Show MACType++-- | Message Authentication Code (MAC) Algorithm.+data MACAlgorithm+ = forall hashAlg . Hash.HashAlgorithm hashAlg+ => HMAC (DigestProxy hashAlg)+ | forall n . KnownNat n => KMAC_SHAKE128 (Proxy n) ByteString+ | forall n . KnownNat n => KMAC_SHAKE256 (Proxy n) ByteString++instance Show MACAlgorithm where+ showsPrec d (HMAC p) = showParen (d > 10) $+ showString "HMAC " . showsPrec 11 p+ showsPrec d (KMAC_SHAKE128 p s) = showParen (d > 10) $+ showString "KMAC_SHAKE128 " . showNat 11 p .+ showChar ' ' . showsPrec 11 s+ showsPrec d (KMAC_SHAKE256 p s) = showParen (d > 10) $+ showString "KMAC_SHAKE256 " . showNat 11 p .+ showChar ' ' . showsPrec 11 s++instance Eq MACAlgorithm where+ HMAC a1 == HMAC a2 =+ DigestAlgorithm a1 == DigestAlgorithm a2+ KMAC_SHAKE128 p1 s1 == KMAC_SHAKE128 p2 s2 =+ natVal p1 == natVal p2 && s1 == s2+ KMAC_SHAKE256 p1 s1 == KMAC_SHAKE256 p2 s2 =+ natVal p1 == natVal p2 && s1 == s2+ _ == _ = False++instance HasStrength MACAlgorithm where+ getSecurityBits (HMAC a) = getSecurityBits (DigestAlgorithm a)+ getSecurityBits (KMAC_SHAKE128 p _) = shakeSecurityBits 128 p+ getSecurityBits (KMAC_SHAKE256 p _) = shakeSecurityBits 256 p++instance Enumerable MACType where+ values = [ TypeHMAC MD5+ , TypeHMAC SHA1+ , TypeHMAC SHA224+ , TypeHMAC SHA256+ , TypeHMAC SHA384+ , TypeHMAC SHA512+ , TypeKMAC_SHAKE128+ , TypeKMAC_SHAKE256+ ]++instance OIDable MACType where+ getObjectID (TypeHMAC MD5) = [1,3,6,1,5,5,8,1,1]+ getObjectID (TypeHMAC SHA1) = [1,3,6,1,5,5,8,1,2]+ getObjectID (TypeHMAC SHA224) = [1,2,840,113549,2,8]+ getObjectID (TypeHMAC SHA256) = [1,2,840,113549,2,9]+ getObjectID (TypeHMAC SHA384) = [1,2,840,113549,2,10]+ getObjectID (TypeHMAC SHA512) = [1,2,840,113549,2,11]+ getObjectID TypeKMAC_SHAKE128 = [2,16,840,1,101,3,4,2,19]+ getObjectID TypeKMAC_SHAKE256 = [2,16,840,1,101,3,4,2,20]++ getObjectID ty = error ("Unsupported MACAlgorithm: " ++ show ty)++instance OIDNameable MACType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++instance AlgorithmId MACAlgorithm where+ type AlgorithmType MACAlgorithm = MACType+ algorithmName _ = "mac algorithm"++ algorithmType (HMAC alg) = TypeHMAC alg+ algorithmType (KMAC_SHAKE128 _ _) = TypeKMAC_SHAKE128+ algorithmType (KMAC_SHAKE256 _ _) = TypeKMAC_SHAKE256++ parameterASN1S (HMAC _) = id+ parameterASN1S (KMAC_SHAKE128 p str) = kmacASN1S 256 p str+ parameterASN1S (KMAC_SHAKE256 p str) = kmacASN1S 512 p str++ parseParameter (TypeHMAC alg) = getNextMaybe nullOrNothing >> return (HMAC alg)+ parseParameter TypeKMAC_SHAKE128 = parseKMAC p256 KMAC_SHAKE128+ parseParameter TypeKMAC_SHAKE256 = parseKMAC p512 KMAC_SHAKE256++kmacASN1S :: (KnownNat n, ASN1Elem e)+ => Integer -> proxy n -> ByteString -> ASN1Stream e+kmacASN1S n p str+ | B.null str && n == i = id+ | otherwise = asn1Container Sequence (gIntVal i . gOctetString str)+ where i = natVal p++parseKMAC :: (Monoid e, KnownNat n')+ => Proxy n'+ -> (forall n . KnownNat n => Proxy n -> ByteString -> MACAlgorithm)+ -> ParseASN1 e MACAlgorithm+parseKMAC p' fn = do+ b <- hasNext+ if b then parseParams else return (fn p' B.empty)+ where+ parseParams = onNextContainer Sequence $ parseBitLen $ \(SomeNat p) ->+ getNext >>= \(OctetString str) -> return (fn p str)++instance HasKeySize MACAlgorithm where+ getKeySizeSpecifier (HMAC a) = KeySizeFixed (digestSizeFromProxy a)+ getKeySizeSpecifier (KMAC_SHAKE128 p _) =+ KeySizeFixed (digestSizeFromProxy (SHAKE128 p))+ getKeySizeSpecifier (KMAC_SHAKE256 p _) =+ KeySizeFixed (digestSizeFromProxy (SHAKE256 p))++digestSizeFromProxy :: Hash.HashAlgorithm a => proxy a -> Int+digestSizeFromProxy = Hash.hashDigestSize . hashFromProxy++-- | Invoke the MAC function.+mac :: (ByteArrayAccess key, ByteArrayAccess message)+ => MACAlgorithm -> key -> message -> MessageAuthenticationCode+mac (HMAC alg) = hmacWith alg+ where+ hmacWith p key = AuthTag . B.convert . runHMAC p key++ runHMAC :: (Hash.HashAlgorithm a, ByteArrayAccess k, ByteArrayAccess m)+ => proxy a -> k -> m -> HMAC.HMAC a+ runHMAC _ = HMAC.hmac++mac (KMAC_SHAKE128 p str) = \key -> AuthTag . B.convert . run128 p str key+ where+ run128 :: (KnownNat n, ByteArrayAccess k, ByteArrayAccess m)+ => proxy n -> ByteString -> k -> m -> KMAC.KMAC (Hash.SHAKE128 n)+ run128 _ = KMAC.kmac++mac (KMAC_SHAKE256 p str) = \key -> AuthTag . B.convert . run256 p str key+ where+ run256 :: (KnownNat n, ByteArrayAccess k, ByteArrayAccess m)+ => proxy n -> ByteString -> k -> m -> KMAC.KMAC (Hash.SHAKE256 n)+ run256 _ = KMAC.kmac+++-- Content encryption++-- | CMS content encryption cipher.+data ContentEncryptionCipher cipher where+ -- | DES+ DES :: ContentEncryptionCipher Cipher.DES+ -- | Triple-DES with 2 keys used in alternative direction+ DES_EDE2 :: ContentEncryptionCipher Cipher.DES_EDE2+ -- | Triple-DES with 3 keys used in alternative direction+ DES_EDE3 :: ContentEncryptionCipher Cipher.DES_EDE3+ -- | AES with 128-bit key+ AES128 :: ContentEncryptionCipher Cipher.AES128+ -- | AES with 192-bit key+ AES192 :: ContentEncryptionCipher Cipher.AES192+ -- | AES with 256-bit key+ AES256 :: ContentEncryptionCipher Cipher.AES256+ -- | CAST5 (aka CAST-128) with key between 40 and 128 bits+ CAST5 :: ContentEncryptionCipher Cipher.CAST5+ -- | Camellia with 128-bit key+ Camellia128 :: ContentEncryptionCipher Cipher.Camellia128++deriving instance Show (ContentEncryptionCipher cipher)+deriving instance Eq (ContentEncryptionCipher cipher)++cecI :: ContentEncryptionCipher c -> Int+cecI DES = 0+cecI DES_EDE2 = 1+cecI DES_EDE3 = 2+cecI AES128 = 3+cecI AES192 = 4+cecI AES256 = 5+cecI CAST5 = 6+cecI Camellia128 = 7++getCipherKeySizeSpecifier :: Cipher cipher => proxy cipher -> KeySizeSpecifier+getCipherKeySizeSpecifier = cipherKeySize . cipherFromProxy++-- | Cipher and mode of operation for content encryption.+data ContentEncryptionAlg+ = forall c . BlockCipher c => ECB (ContentEncryptionCipher c)+ -- ^ Electronic Codebook+ | forall c . BlockCipher c => CBC (ContentEncryptionCipher c)+ -- ^ Cipher Block Chaining+ | CBC_RC2+ -- ^ RC2 in CBC mode+ | forall c . BlockCipher c => CFB (ContentEncryptionCipher c)+ -- ^ Cipher Feedback+ | forall c . BlockCipher c => CTR (ContentEncryptionCipher c)+ -- ^ Counter++instance Show ContentEncryptionAlg where+ show (ECB c) = shows c "_ECB"+ show (CBC c) = shows c "_CBC"+ show CBC_RC2 = "RC2_CBC"+ show (CFB c) = shows c "_CFB"+ show (CTR c) = shows c "_CTR"++instance Enumerable ContentEncryptionAlg where+ values = [ CBC DES+ , CBC DES_EDE3+ , CBC AES128+ , CBC AES192+ , CBC AES256+ , CBC CAST5+ , CBC Camellia128+ , CBC_RC2++ , ECB DES+ , ECB AES128+ , ECB AES192+ , ECB AES256+ , ECB Camellia128++ , CFB DES+ , CFB AES128+ , CFB AES192+ , CFB AES256+ , CFB Camellia128++ , CTR Camellia128+ ]++instance OIDable ContentEncryptionAlg where+ getObjectID (CBC DES) = [1,3,14,3,2,7]+ getObjectID (CBC DES_EDE3) = [1,2,840,113549,3,7]+ getObjectID (CBC AES128) = [2,16,840,1,101,3,4,1,2]+ getObjectID (CBC AES192) = [2,16,840,1,101,3,4,1,22]+ getObjectID (CBC AES256) = [2,16,840,1,101,3,4,1,42]+ getObjectID (CBC CAST5) = [1,2,840,113533,7,66,10]+ getObjectID (CBC Camellia128) = [1,2,392,200011,61,1,1,1,2]+ getObjectID CBC_RC2 = [1,2,840,113549,3,2]++ getObjectID (ECB DES) = [1,3,14,3,2,6]+ getObjectID (ECB AES128) = [2,16,840,1,101,3,4,1,1]+ getObjectID (ECB AES192) = [2,16,840,1,101,3,4,1,21]+ getObjectID (ECB AES256) = [2,16,840,1,101,3,4,1,41]+ getObjectID (ECB Camellia128) = [0,3,4401,5,3,1,9,1]++ getObjectID (CFB DES) = [1,3,14,3,2,9]+ getObjectID (CFB AES128) = [2,16,840,1,101,3,4,1,4]+ getObjectID (CFB AES192) = [2,16,840,1,101,3,4,1,24]+ getObjectID (CFB AES256) = [2,16,840,1,101,3,4,1,44]+ getObjectID (CFB Camellia128) = [0,3,4401,5,3,1,9,4]++ getObjectID (CTR Camellia128) = [0,3,4401,5,3,1,9,9]++ getObjectID ty = error ("Unsupported ContentEncryptionAlg: " ++ show ty)++instance OIDNameable ContentEncryptionAlg where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Content encryption algorithm with associated parameters (i.e. the+-- initialization vector).+--+-- A value can be generated with 'generateEncryptionParams'.+data ContentEncryptionParams+ = forall c . BlockCipher c => ParamsECB (ContentEncryptionCipher c)+ -- ^ Electronic Codebook+ | forall c . BlockCipher c => ParamsCBC (ContentEncryptionCipher c) (IV c)+ -- ^ Cipher Block Chaining+ | ParamsCBCRC2 Int (IV RC2)+ -- ^ RC2 in CBC mode+ | forall c . BlockCipher c => ParamsCFB (ContentEncryptionCipher c) (IV c)+ -- ^ Cipher Feedback+ | forall c . BlockCipher c => ParamsCTR (ContentEncryptionCipher c) (IV c)+ -- ^ Counter++instance Show ContentEncryptionParams where+ show = show . getContentEncryptionAlg++instance Eq ContentEncryptionParams where+ ParamsECB c1 == ParamsECB c2 = cecI c1 == cecI c2+ ParamsCBC c1 iv1 == ParamsCBC c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2+ ParamsCBCRC2 i1 iv1 == ParamsCBCRC2 i2 iv2 = i1 == i2 && iv1 `B.eq` iv2+ ParamsCFB c1 iv1 == ParamsCFB c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2+ ParamsCTR c1 iv1 == ParamsCTR c2 iv2 = cecI c1 == cecI c2 && iv1 `B.eq` iv2+ _ == _ = False++instance HasKeySize ContentEncryptionParams where+ getKeySizeSpecifier (ParamsECB c) = getCipherKeySizeSpecifier c+ getKeySizeSpecifier (ParamsCBC c _) = getCipherKeySizeSpecifier c+ getKeySizeSpecifier (ParamsCBCRC2 i _) = KeySizeFixed $ (i + 7) `div` 8+ getKeySizeSpecifier (ParamsCFB c _) = getCipherKeySizeSpecifier c+ getKeySizeSpecifier (ParamsCTR c _) = getCipherKeySizeSpecifier c++instance ASN1Elem e => ProduceASN1Object e ContentEncryptionParams where+ asn1s param =+ asn1Container Sequence (oid . params)+ where+ oid = gOID (getObjectID $ getContentEncryptionAlg param)+ params = ceParameterASN1S param++instance Monoid e => ParseASN1Object e ContentEncryptionParams where+ parse = onNextContainer Sequence $ do+ OID oid <- getNext+ withObjectID "content encryption algorithm" oid parseCEParameter++ceParameterASN1S :: ASN1Elem e => ContentEncryptionParams -> ASN1Stream e+ceParameterASN1S (ParamsECB _) = id+ceParameterASN1S (ParamsCBC _ iv) = gOctetString (B.convert iv)+ceParameterASN1S (ParamsCBCRC2 len iv) = rc2ParameterASN1S len iv+ceParameterASN1S (ParamsCFB _ iv) = gOctetString (B.convert iv)+ceParameterASN1S (ParamsCTR _ iv) = gOctetString (B.convert iv)++parseCEParameter :: Monoid e+ => ContentEncryptionAlg -> ParseASN1 e ContentEncryptionParams+parseCEParameter (ECB c) = getMany getNext >> return (ParamsECB c)+parseCEParameter (CBC c) = ParamsCBC c <$> (getNext >>= getIV)+parseCEParameter CBC_RC2 = parseRC2Parameter+parseCEParameter (CFB c) = ParamsCFB c <$> (getNext >>= getIV)+parseCEParameter (CTR c) = ParamsCTR c <$> (getNext >>= getIV)++getIV :: BlockCipher cipher => ASN1 -> ParseASN1 e (IV cipher)+getIV (OctetString ivBs) =+ case makeIV ivBs of+ Nothing -> throwParseError "Bad IV in parsed parameters"+ Just v -> return v+getIV _ = throwParseError "No IV in parsed parameter or incorrect format"++rc2ParameterASN1S :: ASN1Elem e => Int -> IV RC2 -> ASN1Stream e+rc2ParameterASN1S len iv+ | len == 32 = gIV+ | otherwise = asn1Container Sequence (rc2VersionASN1 len . gIV)+ where gIV = gOctetString (B.convert iv)++parseRC2Parameter :: Monoid e => ParseASN1 e ContentEncryptionParams+parseRC2Parameter = parseOnlyIV 32 <|> parseFullParams+ where+ parseOnlyIV len = ParamsCBCRC2 len <$> (getNext >>= getIV)+ parseFullParams = onNextContainer Sequence $+ parseRC2Version >>= parseOnlyIV++-- | Get the content encryption algorithm.+getContentEncryptionAlg :: ContentEncryptionParams -> ContentEncryptionAlg+getContentEncryptionAlg (ParamsECB c) = ECB c+getContentEncryptionAlg (ParamsCBC c _) = CBC c+getContentEncryptionAlg (ParamsCBCRC2 _ _) = CBC_RC2+getContentEncryptionAlg (ParamsCFB c _) = CFB c+getContentEncryptionAlg (ParamsCTR c _) = CTR c++-- | Generate random parameters for the specified content encryption algorithm.+generateEncryptionParams :: MonadRandom m+ => ContentEncryptionAlg -> m ContentEncryptionParams+generateEncryptionParams (ECB c) = return (ParamsECB c)+generateEncryptionParams (CBC c) = ParamsCBC c <$> ivGenerate undefined+generateEncryptionParams CBC_RC2 = ParamsCBCRC2 128 <$> ivGenerate undefined+generateEncryptionParams (CFB c) = ParamsCFB c <$> ivGenerate undefined+generateEncryptionParams (CTR c) = ParamsCTR c <$> ivGenerate undefined++-- | Generate random RC2 parameters with the specified effective key length (in+-- bits).+generateRC2EncryptionParams :: MonadRandom m+ => Int -> m ContentEncryptionParams+generateRC2EncryptionParams len = ParamsCBCRC2 len <$> ivGenerate undefined++-- | Encrypt a bytearray with the specified content encryption key and+-- algorithm.+contentEncrypt :: (ByteArray cek, ByteArray ba)+ => cek+ -> ContentEncryptionParams+ -> ba -> Either StoreError ba+contentEncrypt key params bs =+ case params of+ ParamsECB cipher -> getCipher cipher key >>= (\c -> force $ ecbEncrypt c $ padded c bs)+ ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> force $ cbcEncrypt c iv $ padded c bs)+ ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> force $ cbcEncrypt c iv $ padded c bs)+ ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> force $ cfbEncrypt c iv $ padded c bs)+ ParamsCTR cipher iv -> getCipher cipher key >>= (\c -> force $ ctrCombine c iv $ padded c bs)+ where+ force x = x `seq` Right x+ padded c = pad (PKCS7 $ blockSize c)++-- | Decrypt a bytearray with the specified content encryption key and+-- algorithm.+contentDecrypt :: (ByteArray cek, ByteArray ba)+ => cek+ -> ContentEncryptionParams+ -> ba -> Either StoreError ba+contentDecrypt key params bs =+ case params of+ ParamsECB cipher -> getCipher cipher key >>= (\c -> unpadded c (ecbDecrypt c bs))+ ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> unpadded c (cbcDecrypt c iv bs))+ ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> unpadded c (cbcDecrypt c iv bs))+ ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> unpadded c (cfbDecrypt c iv bs))+ ParamsCTR cipher iv -> getCipher cipher key >>= (\c -> unpadded c (ctrCombine c iv bs))+ where+ unpadded c decrypted =+ case unpad (PKCS7 $ blockSize c) decrypted of+ Nothing -> Left DecryptionFailed+ Just out -> Right out++-- from RFC 2268 section 6+rc2Table :: [Word8]+rc2Table =+ [ 0xbd, 0x56, 0xea, 0xf2, 0xa2, 0xf1, 0xac, 0x2a, 0xb0, 0x93, 0xd1, 0x9c, 0x1b, 0x33, 0xfd, 0xd0+ , 0x30, 0x04, 0xb6, 0xdc, 0x7d, 0xdf, 0x32, 0x4b, 0xf7, 0xcb, 0x45, 0x9b, 0x31, 0xbb, 0x21, 0x5a+ , 0x41, 0x9f, 0xe1, 0xd9, 0x4a, 0x4d, 0x9e, 0xda, 0xa0, 0x68, 0x2c, 0xc3, 0x27, 0x5f, 0x80, 0x36+ , 0x3e, 0xee, 0xfb, 0x95, 0x1a, 0xfe, 0xce, 0xa8, 0x34, 0xa9, 0x13, 0xf0, 0xa6, 0x3f, 0xd8, 0x0c+ , 0x78, 0x24, 0xaf, 0x23, 0x52, 0xc1, 0x67, 0x17, 0xf5, 0x66, 0x90, 0xe7, 0xe8, 0x07, 0xb8, 0x60+ , 0x48, 0xe6, 0x1e, 0x53, 0xf3, 0x92, 0xa4, 0x72, 0x8c, 0x08, 0x15, 0x6e, 0x86, 0x00, 0x84, 0xfa+ , 0xf4, 0x7f, 0x8a, 0x42, 0x19, 0xf6, 0xdb, 0xcd, 0x14, 0x8d, 0x50, 0x12, 0xba, 0x3c, 0x06, 0x4e+ , 0xec, 0xb3, 0x35, 0x11, 0xa1, 0x88, 0x8e, 0x2b, 0x94, 0x99, 0xb7, 0x71, 0x74, 0xd3, 0xe4, 0xbf+ , 0x3a, 0xde, 0x96, 0x0e, 0xbc, 0x0a, 0xed, 0x77, 0xfc, 0x37, 0x6b, 0x03, 0x79, 0x89, 0x62, 0xc6+ , 0xd7, 0xc0, 0xd2, 0x7c, 0x6a, 0x8b, 0x22, 0xa3, 0x5b, 0x05, 0x5d, 0x02, 0x75, 0xd5, 0x61, 0xe3+ , 0x18, 0x8f, 0x55, 0x51, 0xad, 0x1f, 0x0b, 0x5e, 0x85, 0xe5, 0xc2, 0x57, 0x63, 0xca, 0x3d, 0x6c+ , 0xb4, 0xc5, 0xcc, 0x70, 0xb2, 0x91, 0x59, 0x0d, 0x47, 0x20, 0xc8, 0x4f, 0x58, 0xe0, 0x01, 0xe2+ , 0x16, 0x38, 0xc4, 0x6f, 0x3b, 0x0f, 0x65, 0x46, 0xbe, 0x7e, 0x2d, 0x7b, 0x82, 0xf9, 0x40, 0xb5+ , 0x1d, 0x73, 0xf8, 0xeb, 0x26, 0xc7, 0x87, 0x97, 0x25, 0x54, 0xb1, 0x28, 0xaa, 0x98, 0x9d, 0xa5+ , 0x64, 0x6d, 0x7a, 0xd4, 0x10, 0x81, 0x44, 0xef, 0x49, 0xd6, 0xae, 0x2e, 0xdd, 0x76, 0x5c, 0x2f+ , 0xa7, 0x1c, 0xc9, 0x09, 0x69, 0x9a, 0x83, 0xcf, 0x29, 0x39, 0xb9, 0xe9, 0x4c, 0xff, 0x43, 0xab+ ]++rc2Forward :: B.Bytes+rc2Forward = B.pack rc2Table++rc2Reverse :: B.Bytes+rc2Reverse = B.allocAndFreeze (length rc2Table) (loop $ zip [0..] rc2Table)+ where+ loop :: [(Word8, Word8)] -> Ptr Word8 -> IO ()+ loop [] _ = return ()+ loop ((a,b):ts) p = pokeElemOff p (fromIntegral b) a >> loop ts p++rc2VersionASN1 :: ASN1Elem e => Int -> ASN1Stream e+rc2VersionASN1 len = gIntVal v+ where+ v | len < 0 = error "invalid RC2 effective key length"+ | len >= 256 = fromIntegral len+ | otherwise = fromIntegral (B.index rc2Forward len)++parseRC2Version :: Monoid e => ParseASN1 e Int+parseRC2Version = do+ IntVal i <- getNext+ when (i < 0) $ throwParseError "Parsed invalid RC2 effective key length"+ let j = fromIntegral i+ return $ if i >= 256 then j else fromIntegral (B.index rc2Reverse j)+++-- Authenticated-content encryption++-- | Cipher and mode of operation for authenticated-content encryption.+data AuthContentEncryptionAlg+ = AUTH_ENC_128+ -- ^ authEnc with 128-bit key+ | AUTH_ENC_256+ -- ^ authEnc with 256-bit key+ | CHACHA20_POLY1305+ -- ^ ChaCha20-Poly1305 Authenticated Encryption+ | forall c . BlockCipher c => CCM (ContentEncryptionCipher c)+ -- ^ Counter with CBC-MAC+ | forall c . BlockCipher c => GCM (ContentEncryptionCipher c)+ -- ^ Galois Counter Mode++instance Show AuthContentEncryptionAlg where+ show AUTH_ENC_128 = "AUTH_ENC_128"+ show AUTH_ENC_256 = "AUTH_ENC_256"+ show CHACHA20_POLY1305 = "CHACHA20_POLY1305"+ show (CCM c) = shows c "_CCM"+ show (GCM c) = shows c "_GCM"++instance Enumerable AuthContentEncryptionAlg where+ values = [ AUTH_ENC_128+ , AUTH_ENC_256+ , CHACHA20_POLY1305++ , CCM AES128+ , CCM AES192+ , CCM AES256++ , GCM AES128+ , GCM AES192+ , GCM AES256+ ]++instance OIDable AuthContentEncryptionAlg where+ getObjectID AUTH_ENC_128 = [1,2,840,113549,1,9,16,3,15]+ getObjectID AUTH_ENC_256 = [1,2,840,113549,1,9,16,3,16]+ getObjectID CHACHA20_POLY1305 = [1,2,840,113549,1,9,16,3,18]++ getObjectID (CCM AES128) = [2,16,840,1,101,3,4,1,7]+ getObjectID (CCM AES192) = [2,16,840,1,101,3,4,1,27]+ getObjectID (CCM AES256) = [2,16,840,1,101,3,4,1,47]++ getObjectID (GCM AES128) = [2,16,840,1,101,3,4,1,6]+ getObjectID (GCM AES192) = [2,16,840,1,101,3,4,1,26]+ getObjectID (GCM AES256) = [2,16,840,1,101,3,4,1,46]++ getObjectID ty = error ("Unsupported AuthContentEncryptionAlg: " ++ show ty)++instance OIDNameable AuthContentEncryptionAlg where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++data AuthEncParams = AuthEncParams+ { prfAlgorithm :: PBKDF2_PRF+ , encAlgorithm :: ContentEncryptionParams+ , macAlgorithm :: MACAlgorithm+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e AuthEncParams where+ asn1s AuthEncParams{..} = asn1Container Sequence (kdf . encAlg . macAlg)+ where+ kdf = algorithmASN1S (Container Context 0) (asKDF prfAlgorithm)+ encAlg = asn1s encAlgorithm+ macAlg = algorithmASN1S Sequence macAlgorithm++ asKDF algPrf = PBKDF2 { pbkdf2Salt = B.empty+ , pbkdf2IterationCount = 1+ , pbkdf2KeyLength = Nothing+ , pbkdf2Prf = algPrf+ }++instance Monoid e => ParseASN1Object e AuthEncParams where+ parse = onNextContainer Sequence $ do+ kdf <- parseAlgorithmMaybe (Container Context 0)+ encAlg <- parse+ macAlg <- parseAlgorithm Sequence+ prfAlg <-+ case kdf of+ Nothing -> return PBKDF2_SHA1+ Just (PBKDF2 _ _ _ a) -> return a+ Just other -> throwParseError+ ("Unable to use " ++ show other ++ " in AuthEncParams")+ return AuthEncParams { prfAlgorithm = prfAlg+ , encAlgorithm = encAlg+ , macAlgorithm = macAlg+ }++-- | Authenticated-content encryption algorithm with associated parameters+-- (i.e. the nonce).+--+-- A value can be generated with functions 'generateAuthEnc128Params',+-- 'generateAuthEnc256Params', 'generateChaChaPoly1305Params',+-- 'generateCCMParams' and 'generateGCMParams'.+data AuthContentEncryptionParams+ = Params_AUTH_ENC_128 AuthEncParams+ -- ^ authEnc with 128-bit keying material+ | Params_AUTH_ENC_256 AuthEncParams+ -- ^ authEnc with 256-bit keying material+ | Params_CHACHA20_POLY1305 ChaChaPoly1305.Nonce+ -- ^ ChaCha20-Poly1305 Authenticated Encryption+ | forall c . BlockCipher c => ParamsCCM (ContentEncryptionCipher c) B.Bytes CCM_M CCM_L+ -- ^ Counter with CBC-MAC+ | forall c . BlockCipher c => ParamsGCM (ContentEncryptionCipher c) B.Bytes Int+ -- ^ Galois Counter Mode++instance Show AuthContentEncryptionParams where+ show = show . getAuthContentEncryptionAlg++instance Eq AuthContentEncryptionParams where+ Params_AUTH_ENC_128 p1 == Params_AUTH_ENC_128 p2 = p1 == p2+ Params_AUTH_ENC_256 p1 == Params_AUTH_ENC_256 p2 = p1 == p2+ Params_CHACHA20_POLY1305 iv1 == Params_CHACHA20_POLY1305 iv2 =+ iv1 `B.eq` iv2++ ParamsCCM c1 iv1 m1 l1 == ParamsCCM c2 iv2 m2 l2 =+ cecI c1 == cecI c2 && iv1 == iv2 && (m1, l1) == (m2, l2)+ ParamsGCM c1 iv1 len1 == ParamsGCM c2 iv2 len2 =+ cecI c1 == cecI c2 && iv1 == iv2 && len1 == len2+ _ == _ = False++instance HasKeySize AuthContentEncryptionParams where+ getKeySizeSpecifier (Params_AUTH_ENC_128 _) = KeySizeFixed 16+ getKeySizeSpecifier (Params_AUTH_ENC_256 _) = KeySizeFixed 32+ getKeySizeSpecifier (Params_CHACHA20_POLY1305 _) = KeySizeFixed 32+ getKeySizeSpecifier (ParamsCCM c _ _ _) = getCipherKeySizeSpecifier c+ getKeySizeSpecifier (ParamsGCM c _ _) = getCipherKeySizeSpecifier c++instance ASN1Elem e => ProduceASN1Object e AuthContentEncryptionParams where+ asn1s param =+ asn1Container Sequence (oid . params)+ where+ oid = gOID (getObjectID $ getAuthContentEncryptionAlg param)+ params = aceParameterASN1S param++instance Monoid e => ParseASN1Object e AuthContentEncryptionParams where+ parse = onNextContainer Sequence $ do+ OID oid <- getNext+ withObjectID "authenticated-content encryption algorithm" oid+ parseACEParameter++aceParameterASN1S :: ASN1Elem e => AuthContentEncryptionParams -> ASN1Stream e+aceParameterASN1S (Params_AUTH_ENC_128 p) = asn1s p+aceParameterASN1S (Params_AUTH_ENC_256 p) = asn1s p+aceParameterASN1S (Params_CHACHA20_POLY1305 iv) = gOctetString (B.convert iv)+aceParameterASN1S (ParamsCCM _ iv m _) =+ asn1Container Sequence (nonce . icvlen)+ where+ nonce = gOctetString (B.convert iv)+ icvlen = gIntVal (fromIntegral $ getM m)+aceParameterASN1S (ParamsGCM _ iv len) =+ asn1Container Sequence (nonce . icvlen)+ where+ nonce = gOctetString (B.convert iv)+ icvlen = gIntVal (fromIntegral len)++parseACEParameter :: Monoid e+ => AuthContentEncryptionAlg+ -> ParseASN1 e AuthContentEncryptionParams+parseACEParameter AUTH_ENC_128 = Params_AUTH_ENC_128 <$> parse+parseACEParameter AUTH_ENC_256 = Params_AUTH_ENC_256 <$> parse+parseACEParameter CHACHA20_POLY1305 = do+ OctetString bs <- getNext+ case ChaChaPoly1305.nonce12 bs of+ CryptoPassed iv -> return (Params_CHACHA20_POLY1305 iv)+ CryptoFailed e ->+ throwParseError $ "Parsed invalid ChaChaPoly1305 nonce: " ++ show e+parseACEParameter (CCM c) = onNextContainer Sequence $ do+ OctetString iv <- getNext+ let ivlen = B.length iv+ when (ivlen < 7 || ivlen > 13) $+ throwParseError $ "Parsed invalid CCM nonce length: " ++ show ivlen+ let Just l = fromL (15 - ivlen)+ m <- parseM+ return (ParamsCCM c (B.convert iv) m l)+parseACEParameter (GCM c) = onNextContainer Sequence $ do+ OctetString iv <- getNext+ when (B.null iv) $+ throwParseError "Parsed empty GCM nonce"+ icvlen <- fromMaybe 12 <$> getNextMaybe intOrNothing+ when (icvlen < 12 || icvlen > 16) $+ throwParseError $ "Parsed invalid GCM ICV length: " ++ show icvlen+ return (ParamsGCM c (B.convert iv) $ fromIntegral icvlen)++-- | Get the authenticated-content encryption algorithm.+getAuthContentEncryptionAlg :: AuthContentEncryptionParams+ -> AuthContentEncryptionAlg+getAuthContentEncryptionAlg (Params_AUTH_ENC_128 _) = AUTH_ENC_128+getAuthContentEncryptionAlg (Params_AUTH_ENC_256 _) = AUTH_ENC_256+getAuthContentEncryptionAlg (Params_CHACHA20_POLY1305 _) = CHACHA20_POLY1305+getAuthContentEncryptionAlg (ParamsCCM c _ _ _) = CCM c+getAuthContentEncryptionAlg (ParamsGCM c _ _) = GCM c++-- | Generate random 'AUTH_ENC_128' parameters with the specified algorithms.+generateAuthEnc128Params :: MonadRandom m+ => PBKDF2_PRF -> ContentEncryptionAlg -> MACAlgorithm+ -> m AuthContentEncryptionParams+generateAuthEnc128Params prfAlg cea macAlg = do+ params <- generateEncryptionParams cea+ return $ Params_AUTH_ENC_128 $+ AuthEncParams { prfAlgorithm = prfAlg+ , encAlgorithm = params+ , macAlgorithm = macAlg+ }++-- | Generate random 'AUTH_ENC_256' parameters with the specified algorithms.+generateAuthEnc256Params :: MonadRandom m+ => PBKDF2_PRF -> ContentEncryptionAlg -> MACAlgorithm+ -> m AuthContentEncryptionParams+generateAuthEnc256Params prfAlg cea macAlg = do+ params <- generateEncryptionParams cea+ return $ Params_AUTH_ENC_256 $+ AuthEncParams { prfAlgorithm = prfAlg+ , encAlgorithm = params+ , macAlgorithm = macAlg+ }++-- | Generate random 'CHACHA20_POLY1305' parameters.+generateChaChaPoly1305Params :: MonadRandom m => m AuthContentEncryptionParams+generateChaChaPoly1305Params = do+ bs <- nonceGenerate 12+ let iv = throwCryptoError (ChaChaPoly1305.nonce12 bs)+ return (Params_CHACHA20_POLY1305 iv)++-- | Generate random 'CCM' parameters for the specified cipher.+generateCCMParams :: (MonadRandom m, BlockCipher c)+ => ContentEncryptionCipher c -> CCM_M -> CCM_L+ -> m AuthContentEncryptionParams+generateCCMParams c m l = do+ iv <- nonceGenerate (15 - getL l)+ return (ParamsCCM c iv m l)++-- | Generate random 'GCM' parameters for the specified cipher.+generateGCMParams :: (MonadRandom m, BlockCipher c)+ => ContentEncryptionCipher c -> Int+ -> m AuthContentEncryptionParams+generateGCMParams c l = do+ iv <- nonceGenerate 12+ return (ParamsGCM c iv l)++-- | Encrypt a bytearray with the specified authenticated-content encryption+-- key and algorithm.+authContentEncrypt :: forall cek aad ba . (ByteArray cek, ByteArrayAccess aad, ByteArray ba)+ => cek+ -> AuthContentEncryptionParams -> ba+ -> aad -> ba -> Either StoreError (AuthTag, ba)+authContentEncrypt key params paramsRaw aad bs =+ case params of+ Params_AUTH_ENC_128 p -> checkAuthKey 16 key >> authEncrypt p+ Params_AUTH_ENC_256 p -> checkAuthKey 32 key >> authEncrypt p+ Params_CHACHA20_POLY1305 iv -> ccpInit key iv aad >>= ccpEncrypt+ ParamsCCM cipher iv m l -> getAEAD cipher key (AEAD_CCM msglen m l) iv >>= encrypt (getM m)+ ParamsGCM cipher iv len -> getAEAD cipher key AEAD_GCM iv >>= encrypt len+ where+ msglen = B.length bs+ force x = x `seq` Right x++ encrypt :: Int -> AEAD a -> Either StoreError (AuthTag, ba)+ encrypt len aead = force $ aeadSimpleEncrypt aead aad bs len++ ccpEncrypt :: ChaChaPoly1305.State -> Either a (AuthTag, ba)+ ccpEncrypt state = force (found, encrypted)+ where+ (encrypted, state') = ChaChaPoly1305.encrypt bs state+ found = ccpTag (ChaChaPoly1305.finalize state')++ authEncrypt :: AuthEncParams -> Either StoreError (AuthTag, ba)+ authEncrypt p@AuthEncParams{..} = do+ let (encKey, macKey) = authKeys key p+ encrypted <- contentEncrypt encKey encAlgorithm bs+ let macMsg = paramsRaw `B.append` encrypted `B.append` B.convert aad+ found = mac macAlgorithm macKey macMsg+ return (found, encrypted)++-- | Decrypt a bytearray with the specified authenticated-content encryption key+-- and algorithm.+authContentDecrypt :: forall cek aad ba . (ByteArray cek, ByteArrayAccess aad, ByteArray ba)+ => cek+ -> AuthContentEncryptionParams -> ba+ -> aad -> ba -> AuthTag -> Either StoreError ba+authContentDecrypt key params paramsRaw aad bs expected =+ case params of+ Params_AUTH_ENC_128 p -> checkAuthKey 16 key >> authDecrypt p+ Params_AUTH_ENC_256 p -> checkAuthKey 32 key >> authDecrypt p+ Params_CHACHA20_POLY1305 iv -> ccpInit key iv aad >>= ccpDecrypt+ ParamsCCM cipher iv m l -> getAEAD cipher key (AEAD_CCM msglen m l) iv >>= decrypt+ ParamsGCM cipher iv _ -> getAEAD cipher key AEAD_GCM iv >>= decrypt+ where+ msglen = B.length bs+ badMac = Left BadContentMAC++ decrypt :: AEAD a -> Either StoreError ba+ decrypt aead = maybe badMac Right (aeadSimpleDecrypt aead aad bs expected)++ ccpDecrypt :: ChaChaPoly1305.State -> Either StoreError ba+ ccpDecrypt state+ | found == expected = Right decrypted+ | otherwise = badMac+ where+ (decrypted, state') = ChaChaPoly1305.decrypt bs state+ found = ccpTag (ChaChaPoly1305.finalize state')++ authDecrypt :: AuthEncParams -> Either StoreError ba+ authDecrypt p@AuthEncParams{..}+ | not acceptable = Left (InvalidParameter "authEnc MAC too weak")+ | found == expected = contentDecrypt encKey encAlgorithm bs+ | otherwise = badMac+ where+ (encKey, macKey) = authKeys key p+ macMsg = paramsRaw `B.append` bs `B.append` B.convert aad+ found = mac macAlgorithm macKey macMsg+ acceptable = securityAcceptable macAlgorithm++getAEAD :: (BlockCipher cipher, ByteArray key, ByteArrayAccess iv)+ => proxy cipher -> key -> AEADMode -> iv -> Either StoreError (AEAD cipher)+getAEAD cipher key mode iv = do+ c <- getCipher cipher key+ fromCryptoFailable $ aeadInit mode c iv++authKeys :: ByteArrayAccess password+ => password -> AuthEncParams+ -> (B.ScrubbedBytes, B.ScrubbedBytes)+authKeys key AuthEncParams{..} = (encKey, macKey)+ where+ encKDF = PBKDF2 "encryption" 1 Nothing prfAlgorithm+ encLen = getMaximumKeySize encAlgorithm+ encKey = kdfDerive encKDF encLen key++ macKDF = PBKDF2 "authentication" 1 Nothing prfAlgorithm+ macKey = kdfDerive macKDF macLen key++ -- RFC 6476 section 4.2: "Specifying a MAC key size gets a bit tricky"+ -- TODO: this is a hack but allows both test vectors to pass+ macLen | encLen == 24 = 16+ | otherwise = getMaximumKeySize macAlgorithm++checkAuthKey :: ByteArrayAccess cek => Int -> cek -> Either StoreError ()+checkAuthKey sz key+ | actual == sz = Right ()+ | otherwise = Left (CryptoError CryptoError_KeySizeInvalid)+ where actual = B.length key++ccpInit :: (ByteArrayAccess key, ByteArrayAccess aad)+ => key+ -> ChaChaPoly1305.Nonce+ -> aad+ -> Either StoreError ChaChaPoly1305.State+ccpInit key nonce aad = case ChaChaPoly1305.initialize key nonce of+ CryptoPassed s -> return (addAAD s)+ CryptoFailed e -> Left (CryptoError e)+ where addAAD = ChaChaPoly1305.finalizeAAD . ChaChaPoly1305.appendAAD aad++ccpTag :: Poly1305.Auth -> AuthTag+ccpTag (Poly1305.Auth bs) = AuthTag bs++-- PRF++-- | Pseudorandom function used for PBKDF2.+data PBKDF2_PRF = PBKDF2_SHA1 -- ^ hmacWithSHA1+ | PBKDF2_SHA256 -- ^ hmacWithSHA256+ | PBKDF2_SHA512 -- ^ hmacWithSHA512+ deriving (Show,Eq)++instance Enumerable PBKDF2_PRF where+ values = [ PBKDF2_SHA1+ , PBKDF2_SHA256+ , PBKDF2_SHA512+ ]++instance OIDable PBKDF2_PRF where+ getObjectID PBKDF2_SHA1 = [1,2,840,113549,2,7]+ getObjectID PBKDF2_SHA256 = [1,2,840,113549,2,9]+ getObjectID PBKDF2_SHA512 = [1,2,840,113549,2,11]++instance OIDNameable PBKDF2_PRF where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++instance AlgorithmId PBKDF2_PRF where+ type AlgorithmType PBKDF2_PRF = PBKDF2_PRF+ algorithmName _ = "PBKDF2 PRF"+ algorithmType = id+ parameterASN1S _ = id+ parseParameter p = getNextMaybe nullOrNothing >> return p++-- | Invoke the pseudorandom function.+prf :: (ByteArrayAccess salt, ByteArrayAccess password, ByteArray out)+ => PBKDF2_PRF -> PBKDF2.Parameters -> password -> salt -> out+prf PBKDF2_SHA1 = PBKDF2.fastPBKDF2_SHA1+prf PBKDF2_SHA256 = PBKDF2.fastPBKDF2_SHA256+prf PBKDF2_SHA512 = PBKDF2.fastPBKDF2_SHA512+++-- Key derivation++-- | Salt value used for key derivation.+type Salt = ByteString++-- | Key derivation algorithm.+data KeyDerivationAlgorithm = TypePBKDF2 | TypeScrypt++instance Enumerable KeyDerivationAlgorithm where+ values = [ TypePBKDF2+ , TypeScrypt+ ]++instance OIDable KeyDerivationAlgorithm where+ getObjectID TypePBKDF2 = [1,2,840,113549,1,5,12]+ getObjectID TypeScrypt = [1,3,6,1,4,1,11591,4,11]++instance OIDNameable KeyDerivationAlgorithm where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Key derivation algorithm and associated parameters.+data KeyDerivationFunc =+ -- | Key derivation with PBKDF2+ PBKDF2 { pbkdf2Salt :: Salt -- ^ Salt value+ , pbkdf2IterationCount :: Int -- ^ Iteration count+ , pbkdf2KeyLength :: Maybe Int -- ^ Optional key length+ , pbkdf2Prf :: PBKDF2_PRF -- ^ Pseudorandom function+ }+ -- | Key derivation with Scrypt+ | Scrypt { scryptSalt :: Salt -- ^ Salt value+ , scryptN :: Word64 -- ^ N value+ , scryptR :: Int -- ^ R value+ , scryptP :: Int -- ^ P value+ , scryptKeyLength :: Maybe Int -- ^ Optional key length+ }+ deriving (Show,Eq)++instance AlgorithmId KeyDerivationFunc where+ type AlgorithmType KeyDerivationFunc = KeyDerivationAlgorithm++ algorithmName _ = "key derivation algorithm"+ algorithmType PBKDF2{} = TypePBKDF2+ algorithmType Scrypt{} = TypeScrypt++ parameterASN1S PBKDF2{..} =+ asn1Container Sequence (salt . iters . keyLen . mprf)+ where+ salt = gOctetString pbkdf2Salt+ iters = gIntVal (toInteger pbkdf2IterationCount)+ keyLen = maybe id (gIntVal . toInteger) pbkdf2KeyLength+ mprf = if pbkdf2Prf == PBKDF2_SHA1 then id else algorithmASN1S Sequence pbkdf2Prf++ parameterASN1S Scrypt{..} =+ asn1Container Sequence (salt . n . r . p . keyLen)+ where+ salt = gOctetString scryptSalt+ n = gIntVal (toInteger scryptN)+ r = gIntVal (toInteger scryptR)+ p = gIntVal (toInteger scryptP)+ keyLen = maybe id (gIntVal . toInteger) scryptKeyLength++ parseParameter TypePBKDF2 = onNextContainer Sequence $ do+ OctetString salt <- getNext+ IntVal iters <- getNext+ keyLen <- getNextMaybe intOrNothing+ b <- hasNext+ mprf <- if b then parseAlgorithm Sequence else return PBKDF2_SHA1+ return PBKDF2 { pbkdf2Salt = salt+ , pbkdf2IterationCount = fromInteger iters+ , pbkdf2KeyLength = fromInteger <$> keyLen+ , pbkdf2Prf = mprf+ }++ parseParameter TypeScrypt = onNextContainer Sequence $ do+ OctetString salt <- getNext+ IntVal n <- getNext+ IntVal r <- getNext+ IntVal p <- getNext+ keyLen <- getNextMaybe intOrNothing+ return Scrypt { scryptSalt = salt+ , scryptN = fromInteger n+ , scryptR = fromInteger r+ , scryptP = fromInteger p+ , scryptKeyLength = fromInteger <$> keyLen+ }++-- | Return the optional key length stored in the KDF parameters.+kdfKeyLength :: KeyDerivationFunc -> Maybe Int+kdfKeyLength PBKDF2{..} = pbkdf2KeyLength+kdfKeyLength Scrypt{..} = scryptKeyLength++-- | Run a key derivation function to produce a result of the specified length+-- using the supplied password.+kdfDerive :: (ByteArrayAccess password, ByteArray out)+ => KeyDerivationFunc -> Int -> password -> out+kdfDerive PBKDF2{..} len pwd = prf pbkdf2Prf params pwd pbkdf2Salt+ where params = PBKDF2.Parameters pbkdf2IterationCount len+kdfDerive Scrypt{..} len pwd = Scrypt.generate params pwd scryptSalt+ where params = Scrypt.Parameters { Scrypt.n = scryptN+ , Scrypt.r = scryptR+ , Scrypt.p = scryptP+ , Scrypt.outputLength = len+ }++-- | Generate a random salt with the specified length in bytes. To be most+-- effective, the length should be at least 8 bytes.+generateSalt :: MonadRandom m => Int -> m Salt+generateSalt = getRandomBytes+++-- Key encryption++data KeyEncryptionType = TypePWRIKEK+ | TypeAES128_WRAP+ | TypeAES192_WRAP+ | TypeAES256_WRAP+ | TypeAES128_WRAP_PAD+ | TypeAES192_WRAP_PAD+ | TypeAES256_WRAP_PAD+ | TypeDES_EDE3_WRAP+ | TypeRC2_WRAP++instance Enumerable KeyEncryptionType where+ values = [ TypePWRIKEK+ , TypeAES128_WRAP+ , TypeAES192_WRAP+ , TypeAES256_WRAP+ , TypeAES128_WRAP_PAD+ , TypeAES192_WRAP_PAD+ , TypeAES256_WRAP_PAD+ , TypeDES_EDE3_WRAP+ , TypeRC2_WRAP+ ]++instance OIDable KeyEncryptionType where+ getObjectID TypePWRIKEK = [1,2,840,113549,1,9,16,3,9]++ getObjectID TypeAES128_WRAP = [2,16,840,1,101,3,4,1,5]+ getObjectID TypeAES192_WRAP = [2,16,840,1,101,3,4,1,25]+ getObjectID TypeAES256_WRAP = [2,16,840,1,101,3,4,1,45]++ getObjectID TypeAES128_WRAP_PAD = [2,16,840,1,101,3,4,1,8]+ getObjectID TypeAES192_WRAP_PAD = [2,16,840,1,101,3,4,1,28]+ getObjectID TypeAES256_WRAP_PAD = [2,16,840,1,101,3,4,1,48]++ getObjectID TypeDES_EDE3_WRAP = [1,2,840,113549,1,9,16,3,6]+ getObjectID TypeRC2_WRAP = [1,2,840,113549,1,9,16,3,7]++instance OIDNameable KeyEncryptionType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Key encryption algorithm with associated parameters (i.e. the underlying+-- encryption algorithm).+data KeyEncryptionParams = PWRIKEK ContentEncryptionParams -- ^ PWRI-KEK key wrap algorithm+ | AES128_WRAP -- ^ AES-128 key wrap+ | AES192_WRAP -- ^ AES-192 key wrap+ | AES256_WRAP -- ^ AES-256 key wrap+ | AES128_WRAP_PAD -- ^ AES-128 extended key wrap+ | AES192_WRAP_PAD -- ^ AES-192 extended key wrap+ | AES256_WRAP_PAD -- ^ AES-256 extended key wrap+ | DES_EDE3_WRAP -- ^ Triple-DES key wrap+ | RC2_WRAP Int -- ^ RC2 key wrap with effective key length+ deriving (Show,Eq)++instance AlgorithmId KeyEncryptionParams where+ type AlgorithmType KeyEncryptionParams = KeyEncryptionType+ algorithmName _ = "key encryption algorithm"++ algorithmType (PWRIKEK _) = TypePWRIKEK+ algorithmType AES128_WRAP = TypeAES128_WRAP+ algorithmType AES192_WRAP = TypeAES192_WRAP+ algorithmType AES256_WRAP = TypeAES256_WRAP+ algorithmType AES128_WRAP_PAD = TypeAES128_WRAP_PAD+ algorithmType AES192_WRAP_PAD = TypeAES192_WRAP_PAD+ algorithmType AES256_WRAP_PAD = TypeAES256_WRAP_PAD+ algorithmType DES_EDE3_WRAP = TypeDES_EDE3_WRAP+ algorithmType (RC2_WRAP _) = TypeRC2_WRAP++ parameterASN1S (PWRIKEK cep) = asn1s cep+ parameterASN1S DES_EDE3_WRAP = gNull+ parameterASN1S (RC2_WRAP ekl) = rc2VersionASN1 ekl+ parameterASN1S _ = id++ parseParameter TypePWRIKEK = PWRIKEK <$> parse+ parseParameter TypeAES128_WRAP = return AES128_WRAP+ parseParameter TypeAES192_WRAP = return AES192_WRAP+ parseParameter TypeAES256_WRAP = return AES256_WRAP+ parseParameter TypeAES128_WRAP_PAD = return AES128_WRAP_PAD+ parseParameter TypeAES192_WRAP_PAD = return AES192_WRAP_PAD+ parseParameter TypeAES256_WRAP_PAD = return AES256_WRAP_PAD+ parseParameter TypeDES_EDE3_WRAP = getNextMaybe nullOrNothing >> return DES_EDE3_WRAP+ parseParameter TypeRC2_WRAP = RC2_WRAP <$> parseRC2Version++instance HasKeySize KeyEncryptionParams where+ getKeySizeSpecifier (PWRIKEK cep) = getKeySizeSpecifier cep+ getKeySizeSpecifier AES128_WRAP = getCipherKeySizeSpecifier AES128+ getKeySizeSpecifier AES192_WRAP = getCipherKeySizeSpecifier AES192+ getKeySizeSpecifier AES256_WRAP = getCipherKeySizeSpecifier AES256+ getKeySizeSpecifier AES128_WRAP_PAD = getCipherKeySizeSpecifier AES128+ getKeySizeSpecifier AES192_WRAP_PAD = getCipherKeySizeSpecifier AES192+ getKeySizeSpecifier AES256_WRAP_PAD = getCipherKeySizeSpecifier AES256+ getKeySizeSpecifier DES_EDE3_WRAP = getCipherKeySizeSpecifier DES_EDE3+ getKeySizeSpecifier (RC2_WRAP _) = KeySizeFixed 16++-- | Encrypt a key with the specified key encryption key and algorithm.+keyEncrypt :: (MonadRandom m, ByteArray kek, ByteArray ba)+ => kek -> KeyEncryptionParams -> ba -> m (Either StoreError ba)+keyEncrypt key (PWRIKEK params) bs =+ case params of+ ParamsECB cipher -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt (const . ecbEncrypt) c undefined bs) cc+ ParamsCBC cipher iv -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt cbcEncrypt c iv bs) cc+ ParamsCBCRC2 len iv -> let cc = getRC2Cipher len key in either (return . Left) (\c -> wrapEncrypt cbcEncrypt c iv bs) cc+ ParamsCFB cipher iv -> let cc = getCipher cipher key in either (return . Left) (\c -> wrapEncrypt cfbEncrypt c iv bs) cc+ ParamsCTR _ _ -> return $ Left (InvalidParameter "Unable to wrap key in CTR mode")+keyEncrypt key AES128_WRAP bs = return (getCipher AES128 key >>= (`AES_KW.wrap` bs))+keyEncrypt key AES192_WRAP bs = return (getCipher AES192 key >>= (`AES_KW.wrap` bs))+keyEncrypt key AES256_WRAP bs = return (getCipher AES256 key >>= (`AES_KW.wrap` bs))+keyEncrypt key AES128_WRAP_PAD bs = return (getCipher AES128 key >>= (`AES_KW.wrapPad` bs))+keyEncrypt key AES192_WRAP_PAD bs = return (getCipher AES192 key >>= (`AES_KW.wrapPad` bs))+keyEncrypt key AES256_WRAP_PAD bs = return (getCipher AES256 key >>= (`AES_KW.wrapPad` bs))+keyEncrypt key DES_EDE3_WRAP bs = either (return . Left) (wrap3DES bs) (getCipher DES_EDE3 key)+ where wrap3DES b c = (\iv -> TripleDES_KW.wrap c iv b) <$> ivGenerate c+keyEncrypt key (RC2_WRAP ekl) bs = either (return . Left) (wrapRC2 bs) (getRC2Cipher ekl key)+ where wrapRC2 b c = do iv <- ivGenerate c; RC2_KW.wrap c iv b++-- | Decrypt a key with the specified key encryption key and algorithm.+keyDecrypt :: (ByteArray kek, ByteArray ba)+ => kek -> KeyEncryptionParams -> ba -> Either StoreError ba+keyDecrypt key (PWRIKEK params) bs =+ case params of+ ParamsECB cipher -> getCipher cipher key >>= (\c -> wrapDecrypt (const . ecbDecrypt) c undefined bs)+ ParamsCBC cipher iv -> getCipher cipher key >>= (\c -> wrapDecrypt cbcDecrypt c iv bs)+ ParamsCBCRC2 len iv -> getRC2Cipher len key >>= (\c -> wrapDecrypt cbcDecrypt c iv bs)+ ParamsCFB cipher iv -> getCipher cipher key >>= (\c -> wrapDecrypt cfbDecrypt c iv bs)+ ParamsCTR _ _ -> Left (InvalidParameter "Unable to unwrap key in CTR mode")+keyDecrypt key AES128_WRAP bs = getCipher AES128 key >>= (`AES_KW.unwrap` bs)+keyDecrypt key AES192_WRAP bs = getCipher AES192 key >>= (`AES_KW.unwrap` bs)+keyDecrypt key AES256_WRAP bs = getCipher AES256 key >>= (`AES_KW.unwrap` bs)+keyDecrypt key AES128_WRAP_PAD bs = getCipher AES128 key >>= (`AES_KW.unwrapPad` bs)+keyDecrypt key AES192_WRAP_PAD bs = getCipher AES192 key >>= (`AES_KW.unwrapPad` bs)+keyDecrypt key AES256_WRAP_PAD bs = getCipher AES256 key >>= (`AES_KW.unwrapPad` bs)+keyDecrypt key DES_EDE3_WRAP bs = getCipher DES_EDE3 key >>= (`TripleDES_KW.unwrap` bs)+keyDecrypt key (RC2_WRAP ekl) bs = getRC2Cipher ekl key >>= (`RC2_KW.unwrap` bs)++keyWrap :: (MonadRandom m, ByteArray ba)+ => Int -> ba -> m (Either StoreError ba)+keyWrap sz input+ | inLen < 3 = return $ Left (InvalidInput "keyWrap: input key too short")+ | inLen > 255 = return $ Left (InvalidInput "keyWrap: input key too long")+ | pLen == 0 = return $ Right $ B.concat [ count, check, input ]+ | otherwise = do+ padding <- getRandomBytes pLen+ return $ Right $ B.concat [ count, check, input, padding ]+ where+ inLen = B.length input+ count = B.singleton (fromIntegral inLen)+ check = B.xor input (B.pack [255, 255, 255] :: B.Bytes)+ pLen = sz - (inLen + 4) `mod` sz + comp+ comp = if inLen + 4 > sz then 0 else sz++keyUnwrap :: ByteArray ba => ba -> Either StoreError ba+keyUnwrap input+ | inLen < 4 = Left (InvalidInput "keyUnwrap: invalid wrapped key")+ | valid = Right $ B.take count (B.drop 4 input)+ | otherwise = Left (InvalidInput "keyUnwrap: invalid wrapped key")+ where+ inLen = B.length input+ count = fromIntegral (B.index input 0)+ bytes = [ B.index input (i + 1) `xor` B.index input (i + 4) | i <- [0..2] ]+ valid = foldl1 (.&.) bytes == 0xFF &&! inLen >= count - 4++wrapEncrypt :: (MonadRandom m, BlockCipher cipher, ByteArray ba)+ => (cipher -> IV cipher -> ba -> ba)+ -> cipher -> IV cipher -> ba -> m (Either StoreError ba)+wrapEncrypt encFn cipher iv input = do+ wrapped <- keyWrap sz input+ return (fn <$> wrapped)+ where+ sz = blockSize cipher+ fn formatted =+ let firstPass = encFn cipher iv formatted+ lastBlock = B.dropView firstPass (B.length firstPass - sz)+ Just iv' = makeIV lastBlock+ in encFn cipher iv' firstPass++wrapDecrypt :: (BlockCipher cipher, ByteArray ba)+ => (cipher -> IV cipher -> ba -> ba)+ -> cipher -> IV cipher -> ba -> Either StoreError ba+wrapDecrypt decFn cipher iv input = keyUnwrap (decFn cipher iv firstPass)+ where+ sz = blockSize cipher+ (beg, lb) = B.splitAt (B.length input - sz) input+ lastBlock = decFn cipher iv' lb+ Just iv' = makeIV (B.dropView beg (B.length beg - sz))+ Just iv'' = makeIV lastBlock+ firstPass = decFn cipher iv'' beg `B.append` lastBlock+++-- Key transport++-- | Encryption parameters for RSAES-OAEP.+data OAEPParams = OAEPParams+ { oaepHashAlgorithm :: DigestAlgorithm -- ^ Hash function+ , oaepMaskGenAlgorithm :: MaskGenerationFunc -- ^ Mask generation function+ }+ deriving (Show,Eq)++instance HasStrength OAEPParams where+ getSecurityBits OAEPParams{..} =+ min (getSecurityBits oaepHashAlgorithm)+ (getSecurityBits oaepMaskGenAlgorithm)++withOAEPParams :: forall seed output a . (ByteArrayAccess seed, ByteArray output)+ => OAEPParams+ -> (forall hash . Hash.HashAlgorithm hash => RSAOAEP.OAEPParams hash seed output -> a)+ -> a+withOAEPParams p fn =+ case oaepHashAlgorithm p of+ DigestAlgorithm hashAlg ->+ fn RSAOAEP.OAEPParams+ { RSAOAEP.oaepHash = hashFromProxy hashAlg+ , RSAOAEP.oaepMaskGenAlg = mgf (oaepMaskGenAlgorithm p)+ , RSAOAEP.oaepLabel = Nothing+ }++instance ASN1Elem e => ProduceASN1Object e OAEPParams where+ asn1s OAEPParams{..} =+ asn1Container Sequence (h . m)+ where+ sha1 = DigestAlgorithm SHA1+ tag i = asn1Container (Container Context i)++ h | oaepHashAlgorithm == sha1 = id+ | otherwise = tag 0 (algorithmASN1S Sequence oaepHashAlgorithm)++ m | oaepMaskGenAlgorithm == MGF1 sha1 = id+ | otherwise = tag 1 (algorithmASN1S Sequence oaepMaskGenAlgorithm)++instance Monoid e => ParseASN1Object e OAEPParams where+ parse = onNextContainer Sequence $ do+ h <- tag 0 (parseAlgorithm Sequence)+ m <- tag 1 (parseAlgorithm Sequence)+ _ <- tag 2 parsePSpecified+ return OAEPParams { oaepHashAlgorithm = fromMaybe sha1 h+ , oaepMaskGenAlgorithm = fromMaybe (MGF1 sha1) m+ }+ where+ sha1 = DigestAlgorithm SHA1+ tag i = onNextContainerMaybe (Container Context i)++ parsePSpecified = do+ OID [1,2,840,113549,1,1,9] <- getNext+ OctetString p <- getNext+ guard (B.null p)++data KeyTransportType = TypeRSAES+ | TypeRSAESOAEP++instance Enumerable KeyTransportType where+ values = [ TypeRSAES+ , TypeRSAESOAEP+ ]++instance OIDable KeyTransportType where+ getObjectID TypeRSAES = [1,2,840,113549,1,1,1]+ getObjectID TypeRSAESOAEP = [1,2,840,113549,1,1,7]++instance OIDNameable KeyTransportType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Key transport algorithm with associated parameters.+data KeyTransportParams = RSAES -- ^ RSAES-PKCS1+ | RSAESOAEP OAEPParams -- ^ RSAES-OAEP+ deriving (Show,Eq)++instance AlgorithmId KeyTransportParams where+ type AlgorithmType KeyTransportParams = KeyTransportType+ algorithmName _ = "key transport algorithm"++ algorithmType RSAES = TypeRSAES+ algorithmType (RSAESOAEP _) = TypeRSAESOAEP++ parameterASN1S RSAES = gNull+ parameterASN1S (RSAESOAEP p) = asn1s p++ parseParameter TypeRSAES = getNextMaybe nullOrNothing >> return RSAES+ parseParameter TypeRSAESOAEP = RSAESOAEP <$> parse++-- | Encrypt the specified content with a key-transport algorithm and recipient+-- public key.+transportEncrypt :: MonadRandom m+ => KeyTransportParams+ -> X509.PubKey+ -> ByteString+ -> m (Either StoreError ByteString)+transportEncrypt RSAES (X509.PubKeyRSA pub) bs =+ mapLeft RSAError <$> RSA.encrypt pub bs+transportEncrypt (RSAESOAEP p) (X509.PubKeyRSA pub) bs =+ withOAEPParams p $ \params ->+ mapLeft RSAError <$> RSAOAEP.encrypt params pub bs+transportEncrypt _ _ _ = return $ Left UnexpectedPublicKeyType++-- | Decrypt the specified content with a key-transport algorithm and recipient+-- private key.+transportDecrypt :: MonadRandom m+ => KeyTransportParams+ -> X509.PrivKey+ -> ByteString+ -> m (Either StoreError ByteString)+transportDecrypt RSAES (X509.PrivKeyRSA priv) bs =+ mapLeft RSAError <$> RSA.decryptSafer priv bs+transportDecrypt (RSAESOAEP p) (X509.PrivKeyRSA priv) bs+ | securityAcceptable p =+ withOAEPParams p $ \params ->+ mapLeft RSAError <$> RSAOAEP.decryptSafer params priv bs+ | otherwise = return $ Left (InvalidParameter "OAEP parameters too weak")+transportDecrypt _ _ _ = return $ Left UnexpectedPrivateKeyType+++-- Key agreement++-- | Key derivation function used for key agreement.+data KeyAgreementKDF+ = forall hashAlg . Hash.HashAlgorithm hashAlg+ => KA_X963_KDF (DigestProxy hashAlg)+ -- ^ ANSI-X9.63-KDF key derivation function+ | forall hashAlg . Hash.HashAlgorithm hashAlg+ => KA_HKDF (DigestProxy hashAlg)+ -- ^ Extract-and-Expand HMAC-based key derivation function++deriving instance Show KeyAgreementKDF++instance Eq KeyAgreementKDF where+ KA_X963_KDF a == KA_X963_KDF b = DigestAlgorithm a == DigestAlgorithm b+ KA_HKDF a == KA_HKDF b = DigestAlgorithm a == DigestAlgorithm b+ _ == _ = False++data KeyAgreementType = TypeStdDH KeyAgreementKDF+ | TypeCofactorDH KeyAgreementKDF+ deriving (Show,Eq)++instance Enumerable KeyAgreementType where+ values = [ TypeStdDH (KA_X963_KDF SHA1)+ , TypeStdDH (KA_X963_KDF SHA224)+ , TypeStdDH (KA_X963_KDF SHA256)+ , TypeStdDH (KA_X963_KDF SHA384)+ , TypeStdDH (KA_X963_KDF SHA512)++ , TypeCofactorDH (KA_X963_KDF SHA1)+ , TypeCofactorDH (KA_X963_KDF SHA224)+ , TypeCofactorDH (KA_X963_KDF SHA256)+ , TypeCofactorDH (KA_X963_KDF SHA384)+ , TypeCofactorDH (KA_X963_KDF SHA512)++ , TypeStdDH (KA_HKDF SHA256)+ , TypeStdDH (KA_HKDF SHA384)+ , TypeStdDH (KA_HKDF SHA512)+ ]++instance OIDable KeyAgreementType where+ getObjectID (TypeStdDH (KA_X963_KDF SHA1)) = [1,3,133,16,840,63,0,2]+ getObjectID (TypeStdDH (KA_X963_KDF SHA224)) = [1,3,132,1,11,0]+ getObjectID (TypeStdDH (KA_X963_KDF SHA256)) = [1,3,132,1,11,1]+ getObjectID (TypeStdDH (KA_X963_KDF SHA384)) = [1,3,132,1,11,2]+ getObjectID (TypeStdDH (KA_X963_KDF SHA512)) = [1,3,132,1,11,3]++ getObjectID (TypeCofactorDH (KA_X963_KDF SHA1)) = [1,3,133,16,840,63,0,3]+ getObjectID (TypeCofactorDH (KA_X963_KDF SHA224)) = [1,3,132,1,14,0]+ getObjectID (TypeCofactorDH (KA_X963_KDF SHA256)) = [1,3,132,1,14,1]+ getObjectID (TypeCofactorDH (KA_X963_KDF SHA384)) = [1,3,132,1,14,2]+ getObjectID (TypeCofactorDH (KA_X963_KDF SHA512)) = [1,3,132,1,14,3]++ getObjectID (TypeStdDH (KA_HKDF SHA256)) = [1,2,840,113549,1,9,16,3,19]+ getObjectID (TypeStdDH (KA_HKDF SHA384)) = [1,2,840,113549,1,9,16,3,20]+ getObjectID (TypeStdDH (KA_HKDF SHA512)) = [1,2,840,113549,1,9,16,3,21]++ getObjectID ty = error ("Unsupported KeyAgreementType: " ++ show ty)++instance OIDNameable KeyAgreementType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Key agreement algorithm with associated parameters.+data KeyAgreementParams = StdDH KeyAgreementKDF KeyEncryptionParams+ -- ^ 1-Pass D-H with Stardard ECDH+ | CofactorDH KeyAgreementKDF KeyEncryptionParams+ -- ^ 1-Pass D-H with Cofactor ECDH+ deriving (Show,Eq)++instance AlgorithmId KeyAgreementParams where+ type AlgorithmType KeyAgreementParams = KeyAgreementType+ algorithmName _ = "key agreement algorithm"++ algorithmType (StdDH d _) = TypeStdDH d+ algorithmType (CofactorDH d _) = TypeCofactorDH d++ parameterASN1S (StdDH _ p) = algorithmASN1S Sequence p+ parameterASN1S (CofactorDH _ p) = algorithmASN1S Sequence p++ parseParameter (TypeStdDH d) = StdDH d <$> parseAlgorithm Sequence+ parseParameter (TypeCofactorDH d) = CofactorDH d <$> parseAlgorithm Sequence++ecdhKeyMaterial :: (ByteArrayAccess bin, ByteArray bout)+ => KeyAgreementKDF -> KeyEncryptionParams -> Maybe ByteString -> bin -> bout+ecdhKeyMaterial kdf kep ukm zz =+ case kdf of+ KA_HKDF hashAlg ->+ HKDF.expand (extract hashAlg zz) otherInfo outLen+ KA_X963_KDF hashAlg+ | r == 0 -> B.concat (map chunk [1..d])+ | otherwise -> B.concat (map chunk [1..d]) `B.append` B.take r (chunk $ succ d)+ where+ (d, r) = outLen `divMod` Hash.hashDigestSize prx+ prx = hashFromProxy hashAlg++ chunk = B.convert . Hash.hashFinalize . hashCtx+ hashCtx' = Hash.hashUpdate (Hash.hashInitWith prx) zz+ hashCtx i = Hash.hashUpdate (Hash.hashUpdate hashCtx' $ toWord32 i) otherInfo++ where+ outLen = getMaximumKeySize kep+ outBits = 8 * outLen+ toWord32 = i2ospOf_ 4 . fromIntegral++ extract :: (Hash.HashAlgorithm a, ByteArrayAccess ikm)+ => DigestProxy a -> ikm -> HKDF.PRK a+ extract _ = HKDF.extract (fromMaybe B.empty ukm)++ otherInfo =+ let ki = algorithmASN1S Sequence kep+ eui = case ukm of+ Nothing -> id+ Just bs -> asn1Container (Container Context 0)+ (gOctetString bs)+ spi = asn1Container (Container Context 2)+ (gOctetString $ toWord32 outBits)+ in encodeASN1S $ asn1Container Sequence (ki . eui . spi)++-- | Key pair for ECDH.+data ECDHPair+ = PairEC ECC.Curve ECC.PrivateNumber ECC.Point+ | PairX25519 X25519.SecretKey X25519.PublicKey+ | PairX448 X448.SecretKey X448.PublicKey++-- | Generate an ephemeral ECDH key.+ecdhGenerate :: MonadRandom m => X509.PubKey -> m (Either StoreError ECDHPair)+ecdhGenerate (X509.PubKeyEC pub) =+ case ecPubKeyCurveName pub of+ Nothing -> return $ Left NamedCurveRequired+ Just n -> do+ let curve = ECC.getCurveByName n+ priv <- ECDH.generatePrivate curve+ return $ case unserializePoint curve (X509.pubkeyEC_pub pub) of+ Nothing -> Left (InvalidInput "Invalid serialized point")+ Just pt -> Right (PairEC curve priv pt)+ecdhGenerate (X509.PubKeyX25519 pub) = do+ priv <- X25519.generateSecretKey+ return $ Right (PairX25519 priv pub)+ecdhGenerate (X509.PubKeyX448 pub) = do+ priv <- X448.generateSecretKey+ return $ Right (PairX448 priv pub)+ecdhGenerate _ = return $ Left UnexpectedPublicKeyType++-- | Return the serialized public key corresponding to the ECDH private key.+ecdhPublic :: ECDHPair -> ByteString+ecdhPublic (PairEC curve d _) = unSerialize (getSerializedPoint curve d)+ where unSerialize (X509.SerializedPoint pt) = pt+ecdhPublic (PairX25519 priv _) = B.convert (X25519.toPublic priv)+ecdhPublic (PairX448 priv _) = B.convert (X448.toPublic priv)++-- | Encrypt the specified content with an ECDH key pair and key-agreement+-- algorithm.+ecdhEncrypt :: (MonadRandom m, ByteArray ba)+ => KeyAgreementParams -> Maybe ByteString -> ECDHPair -> ba -> m (Either StoreError ba)+ecdhEncrypt (StdDH dig kep) ukm (PairEC curve d pub) bs = do+ let s = ECDH.getShared curve d pub+ k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyEncrypt k kep bs+ecdhEncrypt (StdDH dig kep) ukm (PairX25519 priv pub) bs =+ case fromCryptoFailable (ecdh x25519 priv pub) of+ Left e -> return (Left e)+ Right s ->+ let k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ in keyEncrypt k kep bs+ecdhEncrypt (StdDH dig kep) ukm (PairX448 priv pub) bs =+ case fromCryptoFailable (ecdh x448 priv pub) of+ Left e -> return (Left e)+ Right s ->+ let k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ in keyEncrypt k kep bs+ecdhEncrypt (CofactorDH dig kep) ukm (PairEC curve d pub) bs = do+ let h = ECC.ecc_h (ECC.common_curve curve)+ s = ECDH.getShared curve (h * d) pub+ k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyEncrypt k kep bs+ecdhEncrypt (CofactorDH _ _) _ (PairX25519 _ _) _ =+ return $ Left (InvalidInput "X25519 is not supported for cofactor DH")+ecdhEncrypt (CofactorDH _ _) _ (PairX448 _ _) _ =+ return $ Left (InvalidInput "X448 is not supported for cofactor DH")++-- | Decrypt the specified content with an ECDH key pair and key-agreement+-- algorithm.+ecdhDecrypt :: ByteArray ba+ => KeyAgreementParams -> Maybe ByteString -> X509.PrivKey -> ByteString -> ba -> Either StoreError ba+ecdhDecrypt (StdDH dig kep) ukm (X509.PrivKeyEC priv) pt bs =+ case ecPrivKeyCurve priv of+ Nothing -> Left UnsupportedEllipticCurve+ Just curve ->+ case unserializePoint curve (X509.SerializedPoint pt) of+ Nothing -> Left (InvalidInput "Invalid serialized point")+ Just pub -> do+ let d = X509.privkeyEC_priv priv+ s = ECDH.getShared curve d pub+ k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyDecrypt k kep bs+ecdhDecrypt (StdDH dig kep) ukm (X509.PrivKeyX25519 priv) pt bs = do+ s <- fromCryptoFailable (X25519.publicKey pt >>= ecdh x25519 priv)+ let k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyDecrypt k kep bs+ecdhDecrypt (StdDH dig kep) ukm (X509.PrivKeyX448 priv) pt bs = do+ s <- fromCryptoFailable (X448.publicKey pt >>= ecdh x448 priv)+ let k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyDecrypt k kep bs+ecdhDecrypt (StdDH _ _) _ _ _ _ = Left UnexpectedPrivateKeyType+ecdhDecrypt (CofactorDH dig kep) ukm (X509.PrivKeyEC priv) pt bs =+ case ecPrivKeyCurve priv of+ Nothing -> Left UnsupportedEllipticCurve+ Just curve ->+ case unserializePoint curve (X509.SerializedPoint pt) of+ Nothing -> Left (InvalidInput "Invalid serialized point")+ Just pub -> do+ let h = ECC.ecc_h (ECC.common_curve curve)+ d = X509.privkeyEC_priv priv+ s = ECDH.getShared curve (h * d) pub+ k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+ keyDecrypt k kep bs+ecdhDecrypt (CofactorDH _ _) _ _ _ _ = Left UnexpectedPrivateKeyType++x25519 :: Proxy Curve_X25519+x25519 = Proxy++x448 :: Proxy Curve_X448+x448 = Proxy+++-- Utilities++getCipher :: (BlockCipher cipher, ByteArray key)+ => proxy cipher -> key -> Either StoreError cipher+getCipher _ key = fromCryptoFailable (cipherInit key)++getRC2Cipher :: ByteArray key => Int -> key -> Either StoreError RC2+getRC2Cipher len key = fromCryptoFailable (rc2WithEffectiveKeyLength len key)++ivGenerate :: (BlockCipher cipher, MonadRandom m) => cipher -> m (IV cipher)+ivGenerate cipher = do+ bs <- getRandomBytes (blockSize cipher)+ let Just iv = makeIV (bs :: ByteString)+ return iv++nonceGenerate :: MonadRandom m => Int -> m B.Bytes+nonceGenerate = getRandomBytes++cipherFromProxy :: proxy cipher -> cipher+cipherFromProxy _ = undefined++-- | Return the block size of the specified block cipher.+proxyBlockSize :: BlockCipher cipher => proxy cipher -> Int+proxyBlockSize = blockSize . cipherFromProxy++getL :: CCM_L -> Int+getL CCM_L2 = 2+getL CCM_L3 = 3+getL CCM_L4 = 4++getM :: CCM_M -> Int+getM CCM_M4 = 4+getM CCM_M6 = 6+getM CCM_M8 = 8+getM CCM_M10 = 10+getM CCM_M12 = 12+getM CCM_M14 = 14+getM CCM_M16 = 16++fromL :: Int -> Maybe CCM_L+fromL 2 = Just CCM_L2+fromL 3 = Just CCM_L3+fromL 4 = Just CCM_L4+fromL _ = Nothing++parseM :: Monoid e => ParseASN1 e CCM_M+parseM = do+ IntVal l <- getNext+ case l of+ 4 -> return CCM_M4+ 6 -> return CCM_M6+ 8 -> return CCM_M8+ 10 -> return CCM_M10+ 12 -> return CCM_M12+ 14 -> return CCM_M14+ 16 -> return CCM_M16+ i -> throwParseError ("Parsed invalid CCM parameter M: " ++ show i)+++-- Mask generation functions++data MaskGenerationType = TypeMGF1+ deriving (Show,Eq)++instance Enumerable MaskGenerationType where+ values = [ TypeMGF1+ ]++instance OIDable MaskGenerationType where+ getObjectID TypeMGF1 = [1,2,840,113549,1,1,8]++instance OIDNameable MaskGenerationType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Mask Generation Functions (MGF) and associated parameters.+newtype MaskGenerationFunc = MGF1 DigestAlgorithm+ deriving (Show,Eq)++instance HasStrength MaskGenerationFunc where+ getSecurityBits (MGF1 d) = getSecurityBits d++instance AlgorithmId MaskGenerationFunc where+ type AlgorithmType MaskGenerationFunc = MaskGenerationType+ algorithmName _ = "mask generation function"++ algorithmType (MGF1 _) = TypeMGF1++ parameterASN1S (MGF1 d) = algorithmASN1S Sequence d++ parseParameter TypeMGF1 = MGF1 <$> parseAlgorithm Sequence++-- | Generate a mask with the MGF.+mgf :: (ByteArrayAccess seed, ByteArray output)+ => MaskGenerationFunc -> seed -> Int -> output+mgf (MGF1 (DigestAlgorithm hashAlg)) = MGF.mgf1 (hashFromProxy hashAlg)+++-- Signature algorithms++-- | Signature value.+type SignatureValue = ByteString++-- | Signature parameters for RSASSA-PSS.+data PSSParams = PSSParams+ { pssHashAlgorithm :: DigestAlgorithm -- ^ Hash function+ , pssMaskGenAlgorithm :: MaskGenerationFunc -- ^ Mask generation function+ , pssSaltLength :: Int -- ^ Length of the salt in bytes+ }+ deriving (Show,Eq)++instance HasStrength PSSParams where+ getSecurityBits PSSParams{..} =+ min (getSecurityBits pssHashAlgorithm)+ (getSecurityBits pssMaskGenAlgorithm)++withPSSParams :: forall seed output a . (ByteArrayAccess seed, ByteArray output)+ => PSSParams+ -> (forall hash . Hash.HashAlgorithm hash => RSAPSS.PSSParams hash seed output -> a)+ -> a+withPSSParams p fn =+ case pssHashAlgorithm p of+ DigestAlgorithm hashAlg ->+ fn RSAPSS.PSSParams+ { RSAPSS.pssHash = hashFromProxy hashAlg+ , RSAPSS.pssMaskGenAlg = mgf (pssMaskGenAlgorithm p)+ , RSAPSS.pssSaltLength = pssSaltLength p+ , RSAPSS.pssTrailerField = 0xbc+ }++instance ASN1Elem e => ProduceASN1Object e PSSParams where+ asn1s PSSParams{..} =+ asn1Container Sequence (h . m . s)+ where+ sha1 = DigestAlgorithm SHA1+ tag i = asn1Container (Container Context i)++ h | pssHashAlgorithm == sha1 = id+ | otherwise = tag 0 (algorithmASN1S Sequence pssHashAlgorithm)++ m | pssMaskGenAlgorithm == MGF1 sha1 = id+ | otherwise = tag 1 (algorithmASN1S Sequence pssMaskGenAlgorithm)++ s | pssSaltLength == 20 && pssHashAlgorithm == sha1 = id+ | otherwise = tag 2 (gIntVal $ fromIntegral pssSaltLength)++instance Monoid e => ParseASN1Object e PSSParams where+ parse = onNextContainer Sequence $ do+ h <- tag 0 (parseAlgorithm Sequence)+ m <- tag 1 (parseAlgorithm Sequence)+ s <- tag 2 $ do { IntVal i <- getNext; return (fromIntegral i) }+ _ <- tag 3 $ do { IntVal 1 <- getNext; return () }+ return PSSParams { pssHashAlgorithm = fromMaybe sha1 h+ , pssMaskGenAlgorithm = fromMaybe (MGF1 sha1) m+ , pssSaltLength = fromMaybe 20 s+ }+ where+ sha1 = DigestAlgorithm SHA1+ tag i = onNextContainerMaybe (Container Context i)++data SignatureType = TypeRSAAnyHash+ | TypeRSA DigestAlgorithm+ | TypeRSAPSS+ | TypeDSA DigestAlgorithm+ | TypeECDSA DigestAlgorithm+ | TypeEd25519+ | TypeEd448+ deriving (Show,Eq)++instance Enumerable SignatureType where+ values = [ TypeRSAAnyHash++ , TypeRSA (DigestAlgorithm MD2)+ , TypeRSA (DigestAlgorithm MD5)+ , TypeRSA (DigestAlgorithm SHA1)+ , TypeRSA (DigestAlgorithm SHA224)+ , TypeRSA (DigestAlgorithm SHA256)+ , TypeRSA (DigestAlgorithm SHA384)+ , TypeRSA (DigestAlgorithm SHA512)++ , TypeRSAPSS++ , TypeDSA (DigestAlgorithm SHA1)+ , TypeDSA (DigestAlgorithm SHA224)+ , TypeDSA (DigestAlgorithm SHA256)++ , TypeECDSA (DigestAlgorithm SHA1)+ , TypeECDSA (DigestAlgorithm SHA224)+ , TypeECDSA (DigestAlgorithm SHA256)+ , TypeECDSA (DigestAlgorithm SHA384)+ , TypeECDSA (DigestAlgorithm SHA512)++ , TypeEd25519+ , TypeEd448+ ]++instance OIDable SignatureType where+ getObjectID TypeRSAAnyHash = [1,2,840,113549,1,1,1]++ getObjectID (TypeRSA (DigestAlgorithm MD2)) = [1,2,840,113549,1,1,2]+ getObjectID (TypeRSA (DigestAlgorithm MD5)) = [1,2,840,113549,1,1,4]+ getObjectID (TypeRSA (DigestAlgorithm SHA1)) = [1,2,840,113549,1,1,5]+ getObjectID (TypeRSA (DigestAlgorithm SHA224)) = [1,2,840,113549,1,1,14]+ getObjectID (TypeRSA (DigestAlgorithm SHA256)) = [1,2,840,113549,1,1,11]+ getObjectID (TypeRSA (DigestAlgorithm SHA384)) = [1,2,840,113549,1,1,12]+ getObjectID (TypeRSA (DigestAlgorithm SHA512)) = [1,2,840,113549,1,1,13]++ getObjectID TypeRSAPSS = [1,2,840,113549,1,1,10]++ getObjectID (TypeDSA (DigestAlgorithm SHA1)) = [1,2,840,10040,4,3]+ getObjectID (TypeDSA (DigestAlgorithm SHA224)) = [2,16,840,1,101,3,4,3,1]+ getObjectID (TypeDSA (DigestAlgorithm SHA256)) = [2,16,840,1,101,3,4,3,2]++ getObjectID (TypeECDSA (DigestAlgorithm SHA1)) = [1,2,840,10045,4,1]+ getObjectID (TypeECDSA (DigestAlgorithm SHA224)) = [1,2,840,10045,4,3,1]+ getObjectID (TypeECDSA (DigestAlgorithm SHA256)) = [1,2,840,10045,4,3,2]+ getObjectID (TypeECDSA (DigestAlgorithm SHA384)) = [1,2,840,10045,4,3,3]+ getObjectID (TypeECDSA (DigestAlgorithm SHA512)) = [1,2,840,10045,4,3,4]++ getObjectID TypeEd25519 = [1,3,101,112]+ getObjectID TypeEd448 = [1,3,101,113]++ getObjectID ty = error ("Unsupported SignatureType: " ++ show ty)++instance OIDNameable SignatureType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | CMS signature algorithms and associated parameters.+data SignatureAlg = RSAAnyHash+ | RSA DigestAlgorithm+ | RSAPSS PSSParams+ | DSA DigestAlgorithm+ | ECDSA DigestAlgorithm+ | Ed25519+ | Ed448+ deriving (Show,Eq)++instance AlgorithmId SignatureAlg where+ type AlgorithmType SignatureAlg = SignatureType+ algorithmName _ = "signature algorithm"++ algorithmType RSAAnyHash = TypeRSAAnyHash+ algorithmType (RSA alg) = TypeRSA alg+ algorithmType (RSAPSS _) = TypeRSAPSS+ algorithmType (DSA alg) = TypeDSA alg+ algorithmType (ECDSA alg) = TypeECDSA alg+ algorithmType Ed25519 = TypeEd25519+ algorithmType Ed448 = TypeEd448++ parameterASN1S RSAAnyHash = gNull+ parameterASN1S (RSA _) = gNull+ parameterASN1S (RSAPSS p) = asn1s p+ parameterASN1S (DSA _) = id+ parameterASN1S (ECDSA _) = id+ parameterASN1S Ed25519 = id+ parameterASN1S Ed448 = id++ parseParameter TypeRSAAnyHash = getNextMaybe nullOrNothing >> return RSAAnyHash+ parseParameter (TypeRSA alg) = getNextMaybe nullOrNothing >> return (RSA alg)+ parseParameter TypeRSAPSS = RSAPSS <$> parse+ parseParameter (TypeDSA alg) = return (DSA alg)+ parseParameter (TypeECDSA alg) = return (ECDSA alg)+ parseParameter TypeEd25519 = return Ed25519+ parseParameter TypeEd448 = return Ed448++-- | Sign a message using the specified algorithm and private key. The+-- corresponding public key is also required for some algorithms.+signatureGenerate :: MonadRandom m => SignatureAlg -> X509.PrivKey -> X509.PubKey -> ByteString -> m (Either StoreError SignatureValue)+signatureGenerate RSAAnyHash _ _ _ =+ error "signatureGenerate: should call signatureResolveHash first"+signatureGenerate (RSA alg) (X509.PrivKeyRSA priv) (X509.PubKeyRSA _) msg =+ let err = return . Left $ InvalidParameter ("Invalid hash algorithm for RSA: " ++ show alg)+ in withHashAlgorithmASN1 alg err $ \hashAlg ->+ mapLeft RSAError <$> RSA.signSafer (Just hashAlg) priv msg+signatureGenerate (RSAPSS p) (X509.PrivKeyRSA priv) (X509.PubKeyRSA _) msg =+ withPSSParams p $ \params ->+ mapLeft RSAError <$> RSAPSS.signSafer params priv msg+signatureGenerate (DSA alg) (X509.PrivKeyDSA priv) (X509.PubKeyDSA _) msg =+ case alg of+ DigestAlgorithm t ->+ Right . dsaFromSignature <$> DSA.sign priv (hashFromProxy t) msg+signatureGenerate (ECDSA alg) (X509.PrivKeyEC priv) (X509.PubKeyEC _) msg =+ case alg of+ DigestAlgorithm t ->+ case ecdsaToPrivateKey priv of+ Nothing -> return (Left UnsupportedEllipticCurve)+ Just p ->+ let h = hashFromProxy t+ in Right . ecdsaFromSignature <$> ECDSA.sign p h msg+signatureGenerate Ed25519 (X509.PrivKeyEd25519 priv) (X509.PubKeyEd25519 pub) msg =+ return . Right . B.convert $ Ed25519.sign priv pub msg+signatureGenerate Ed448 (X509.PrivKeyEd448 priv) (X509.PubKeyEd448 pub) msg =+ return . Right . B.convert $ Ed448.sign priv pub msg+signatureGenerate _ _ _ _ = return (Left UnexpectedPrivateKeyType)++-- | Verify a message signature using the specified algorithm and public key.+signatureVerify :: SignatureAlg -> X509.PubKey -> ByteString -> SignatureValue -> Bool+signatureVerify RSAAnyHash _ _ _ =+ error "signatureVerify: should call signatureResolveHash first"+signatureVerify (RSA alg) (X509.PubKeyRSA pub) msg sig =+ withHashAlgorithmASN1 alg False $ \hashAlg ->+ RSA.verify (Just hashAlg) pub msg sig+signatureVerify (RSAPSS p) (X509.PubKeyRSA pub) msg sig+ | securityAcceptable p =+ withPSSParams p $ \params -> RSAPSS.verify params pub msg sig+ | otherwise = False+signatureVerify (DSA alg) (X509.PubKeyDSA pub) msg sig = fromMaybe False $ do+ s <- dsaToSignature sig+ case alg of+ DigestAlgorithm t -> return $ DSA.verify (hashFromProxy t) pub s msg+signatureVerify (ECDSA alg) (X509.PubKeyEC pub) msg sig = fromMaybe False $ do+ p <- ecdsaToPublicKey pub+ s <- ecdsaToSignature sig+ case alg of+ DigestAlgorithm t -> return $ ECDSA.verify (hashFromProxy t) p s msg+signatureVerify Ed25519 (X509.PubKeyEd25519 pub) msg sig =+ case Ed25519.signature sig of+ CryptoFailed _ -> False+ CryptoPassed s -> Ed25519.verify pub msg s+signatureVerify Ed448 (X509.PubKeyEd448 pub) msg sig =+ case Ed448.signature sig of+ CryptoFailed _ -> False+ CryptoPassed s -> Ed448.verify pub msg s+signatureVerify _ _ _ _ = False++withHashAlgorithmASN1 :: DigestAlgorithm+ -> a+ -> (forall hashAlg . RSA.HashAlgorithmASN1 hashAlg => hashAlg -> a)+ -> a+withHashAlgorithmASN1 (DigestAlgorithm MD2) _ f = f Hash.MD2+withHashAlgorithmASN1 (DigestAlgorithm MD5) _ f = f Hash.MD5+withHashAlgorithmASN1 (DigestAlgorithm SHA1) _ f = f Hash.SHA1+withHashAlgorithmASN1 (DigestAlgorithm SHA224) _ f = f Hash.SHA224+withHashAlgorithmASN1 (DigestAlgorithm SHA256) _ f = f Hash.SHA256+withHashAlgorithmASN1 (DigestAlgorithm SHA384) _ f = f Hash.SHA384+withHashAlgorithmASN1 (DigestAlgorithm SHA512) _ f = f Hash.SHA512+withHashAlgorithmASN1 _ e _ = e++-- | Return on which digest algorithm the specified signature algorithm is+-- based, as well as a substitution algorithm for when a default digest+-- algorithm is required.+signatureResolveHash :: Bool -> DigestAlgorithm -> SignatureAlg -> (DigestAlgorithm, SignatureAlg)+signatureResolveHash _ d RSAAnyHash = (d, RSA d)+signatureResolveHash _ _ alg@(RSA d) = (d, alg)+signatureResolveHash _ _ alg@(RSAPSS p) = (pssHashAlgorithm p, alg)+signatureResolveHash _ _ alg@(DSA d) = (d, alg)+signatureResolveHash _ _ alg@(ECDSA d) = (d, alg)+signatureResolveHash _ _ alg@Ed25519 = (DigestAlgorithm SHA512, alg)+signatureResolveHash True _ alg@Ed448 = (DigestAlgorithm SHAKE256_512, alg)+signatureResolveHash False _ alg@Ed448 = (DigestAlgorithm (SHAKE256 p512), alg)++-- | Check that a signature algorithm is based on the specified digest algorithm+-- and return a substitution algorithm for when a default digest algorithm is+-- required.+signatureCheckHash :: DigestAlgorithm -> SignatureAlg -> Maybe SignatureAlg+signatureCheckHash expected RSAAnyHash = Just $ RSA expected+signatureCheckHash expected alg@(RSA found)+ | expected == found = Just alg+ | otherwise = Nothing+signatureCheckHash expected alg@(RSAPSS p)+ | expected == pssHashAlgorithm p = Just alg+ | otherwise = Nothing+signatureCheckHash expected alg@(DSA found)+ | expected == found = Just alg+ | otherwise = Nothing+signatureCheckHash expected alg@(ECDSA found)+ | expected == found = Just alg+ | otherwise = Nothing+signatureCheckHash expected alg@Ed25519+ | expected == DigestAlgorithm SHA512 = Just alg+ | otherwise = Nothing+signatureCheckHash expected alg@Ed448+ | expected == DigestAlgorithm SHAKE256_512 = Just alg+ | expected == DigestAlgorithm (SHAKE256 p512) = Just alg+ | otherwise = Nothing++dsaToSignature :: ByteString -> Maybe DSA.Signature+dsaToSignature b = tryDecodeAndParse b $ onNextContainer Sequence $ do+ IntVal r <- getNext+ IntVal s <- getNext+ return DSA.Signature { DSA.sign_r = r, DSA.sign_s = s }++dsaFromSignature :: DSA.Signature -> ByteString+dsaFromSignature sig = encodeASN1S $ asn1Container Sequence+ (gIntVal (DSA.sign_r sig) . gIntVal (DSA.sign_s sig))++ecdsaToSignature :: ByteString -> Maybe ECDSA.Signature+ecdsaToSignature b = tryDecodeAndParse b $ onNextContainer Sequence $ do+ IntVal r <- getNext+ IntVal s <- getNext+ return ECDSA.Signature { ECDSA.sign_r = r, ECDSA.sign_s = s }++ecdsaFromSignature :: ECDSA.Signature -> ByteString+ecdsaFromSignature sig = encodeASN1S $ asn1Container Sequence+ (gIntVal (ECDSA.sign_r sig) . gIntVal (ECDSA.sign_s sig))++ecdsaToPublicKey :: X509.PubKeyEC -> Maybe ECDSA.PublicKey+ecdsaToPublicKey key = do+ curve <- ecPubKeyCurve key+ pt <- unserializePoint curve (X509.pubkeyEC_pub key)+ return ECDSA.PublicKey { ECDSA.public_curve = curve, ECDSA.public_q = pt }++ecdsaToPrivateKey :: X509.PrivKeyEC -> Maybe ECDSA.PrivateKey+ecdsaToPrivateKey key = do+ curve <- ecPrivKeyCurve key+ let d = X509.privkeyEC_priv key+ return ECDSA.PrivateKey { ECDSA.private_curve = curve, ECDSA.private_d = d }++tryDecodeAndParse :: ByteString -> ParseASN1 () a -> Maybe a+tryDecodeAndParse b parser =+ either (const Nothing) Just $+ case decodeASN1' BER b of+ Left _ -> Left undefined -- value ignored+ Right asn1 -> runParseASN1 parser asn1
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Attribute.hs view
@@ -0,0 +1,167 @@+-- |+-- Module : Crypto.Store.CMS.Attribute+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- CMS attributes+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Attribute+ ( Attribute(..)+ , attributesASN1S+ , parseAttributes+ -- * Generic attribute+ , findAttribute+ , setAttribute+ , filterAttributes+ -- * Implementing attributes+ , setAttributeASN1S+ , runParseAttribute+ -- * Standard attributes+ , getContentTypeAttr+ , setContentTypeAttr+ , getMessageDigestAttr+ , setMessageDigestAttr+ , getSigningTimeAttr+ , setSigningTimeAttr+ , setSigningTimeAttrCurrent+ ) where++import Control.Monad.IO.Class++import Data.ASN1.Types+import Data.ByteString (ByteString)+import Data.Hourglass+import Data.Maybe (fromMaybe)++import System.Hourglass (dateCurrent)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | An attribute extending the parent structure with arbitrary data.+data Attribute = Attribute+ { attrType :: OID -- ^ Attribute type+ , attrValues :: [ASN1] -- ^ Attribute values+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e Attribute where+ asn1s Attribute{..} =+ asn1Container Sequence+ (gOID attrType . asn1Container Set (gMany attrValues))++instance Monoid e => ParseASN1Object e Attribute where+ parse = onNextContainer Sequence $ do+ OID oid <- getNext+ vals <- onNextContainer Set (getMany getNext)+ return Attribute { attrType = oid, attrValues = vals }++-- | Produce the ASN.1 stream for a list of attributes.+attributesASN1S :: ASN1Elem e+ => ASN1ConstructionType -> [Attribute] -> ASN1Stream e+attributesASN1S _ [] = id+attributesASN1S ty attrs = asn1Container ty (asn1s attrs)++-- | Parse a list of attributes.+parseAttributes :: Monoid e => ASN1ConstructionType -> ParseASN1 e [Attribute]+parseAttributes ty = fromMaybe [] <$> onNextContainerMaybe ty parse++-- | Return the values for the first attribute with the specified type.+findAttribute :: OID -> [Attribute] -> Maybe [ASN1]+findAttribute oid attrs =+ case [ attrValues a | a <- attrs, attrType a == oid ] of+ [] -> Nothing+ (v:_) -> Just v++-- | Filter a list of attributes based on a predicate applied to attribute type.+filterAttributes :: (OID -> Bool) -> [Attribute] -> [Attribute]+filterAttributes p = filter (p . attrType)++-- | Add or replace an attribute in a list of attributes.+setAttribute :: OID -> [ASN1] -> [Attribute] -> [Attribute]+setAttribute oid vals = (:) attr . filterAttributes (/= oid)+ where attr = Attribute { attrType = oid, attrValues = vals }++-- | Find an attribute with the specified attribute and run a parser on the+-- attribute value when found. 'Nothing' is returned if the attribute could not+-- be found but also when the parse failed.+runParseAttribute :: OID -> [Attribute] -> ParseASN1 () a -> Maybe a+runParseAttribute oid attrs p =+ case findAttribute oid attrs of+ Nothing -> Nothing+ Just s -> either (const Nothing) Just (runParseASN1 p s)++-- | Add or replace an attribute in a list of attributes, using 'ASN1S'.+setAttributeASN1S :: OID -> ASN1S -> [Attribute] -> [Attribute]+setAttributeASN1S oid g = setAttribute oid (g [])+++-- Content type++contentType :: OID+contentType = [1,2,840,113549,1,9,3]++-- | Return the value of the @contentType@ attribute.+getContentTypeAttr :: [Attribute] -> Maybe ContentType+getContentTypeAttr attrs = runParseAttribute contentType attrs $ do+ OID oid <- getNext+ withObjectID "content type" oid return++-- | Add or replace the @contentType@ attribute in a list of attributes.+setContentTypeAttr :: ContentType -> [Attribute] -> [Attribute]+setContentTypeAttr ct = setAttributeASN1S contentType (gOID $ getObjectID ct)+++-- Message digest++messageDigest :: OID+messageDigest = [1,2,840,113549,1,9,4]++-- | Return the value of the @messageDigest@ attribute.+getMessageDigestAttr :: [Attribute] -> Maybe ByteString+getMessageDigestAttr attrs = runParseAttribute messageDigest attrs $ do+ OctetString d <- getNext+ return d++-- | Add or replace the @messageDigest@ attribute in a list of attributes.+setMessageDigestAttr :: ByteString -> [Attribute] -> [Attribute]+setMessageDigestAttr d = setAttributeASN1S messageDigest (gOctetString d)+++-- Signing time++signingTime :: OID+signingTime = [1,2,840,113549,1,9,5]++-- | Return the value of the @signingTime@ attribute.+getSigningTimeAttr :: [Attribute] -> Maybe DateTime+getSigningTimeAttr attrs = runParseAttribute signingTime attrs $ do+ ASN1Time _ t offset <- getNext+ let validOffset = maybe True (== TimezoneOffset 0) offset+ if validOffset+ then return t+ else fail "getSigningTimeAttr: invalid timezone"++-- | Add or replace the @signingTime@ attribute in a list of attributes.+setSigningTimeAttr :: DateTime -> [Attribute] -> [Attribute]+setSigningTimeAttr t =+ let normalize val = val { dtTime = (dtTime val) { todNSec = 0 } }+ offset = Just (TimezoneOffset 0)+ ty | t >= timeConvert (Date 2050 January 1) = TimeGeneralized+ | t < timeConvert (Date 1950 January 1) = TimeGeneralized+ | otherwise = TimeUTC+ in setAttributeASN1S signingTime (gASN1Time ty (normalize t) offset)++-- | Add or replace the @signingTime@ attribute in a list of attributes with the+-- current time. This is equivalent to calling 'setSigningTimeAttr' with the+-- result of 'dateCurrent'.+setSigningTimeAttrCurrent :: MonadIO m => [Attribute] -> m [Attribute]+setSigningTimeAttrCurrent attrs = do+ t <- liftIO dateCurrent+ return (setSigningTimeAttr t attrs)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/AuthEnveloped.hs view
@@ -0,0 +1,97 @@+-- |+-- Module : Crypto.Store.CMS.AuthEnveloped+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.AuthEnveloped+ ( AuthEnvelopedData(..)+ , encodeAuthAttrs+ ) where++import Control.Applicative+import Control.Monad++import Data.ASN1.Types+import Data.ByteArray (convert)+import Data.ByteString (ByteString)++import Crypto.Cipher.Types++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.OriginatorInfo+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | Authenticated-enveloped content information.+data AuthEnvelopedData content = AuthEnvelopedData+ { aeOriginatorInfo :: OriginatorInfo+ -- ^ Optional information about the originator+ , aeRecipientInfos :: [RecipientInfo]+ -- ^ Information for recipients, allowing to decrypt the content+ , aeContentType :: ContentType+ -- ^ Inner content type+ , aeContentEncryptionParams :: ASN1ObjectExact AuthContentEncryptionParams+ -- ^ Encryption algorithm+ , aeEncryptedContent :: content+ -- ^ Encrypted content info+ , aeAuthAttrs :: [Attribute]+ -- ^ Optional authenticated attributes+ , aeMAC :: MessageAuthenticationCode+ -- ^ Message authentication code+ , aeUnauthAttrs :: [Attribute]+ -- ^ Optional unauthenticated attributes+ }+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P (AuthEnvelopedData (Encap EncryptedContent)) where+ asn1s AuthEnvelopedData{..} =+ asn1Container Sequence (ver . oi . ris . eci . aa . tag . ua)+ where+ ver = gIntVal 0+ ris = asn1Container Set (asn1s aeRecipientInfos)+ eci = encryptedContentInfoASN1S+ (aeContentType, aeContentEncryptionParams, aeEncryptedContent)+ aa = attributesASN1S (Container Context 1) aeAuthAttrs+ tag = gOctetString (convert aeMAC)+ ua = attributesASN1S (Container Context 2) aeUnauthAttrs++ oi | aeOriginatorInfo == mempty = id+ | otherwise = originatorInfoASN1S (Container Context 0) aeOriginatorInfo++instance ParseASN1Object [ASN1Event] (AuthEnvelopedData (Encap EncryptedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v /= 0) $+ throwParseError ("AuthEnvelopedData: parsed invalid version: " ++ show v)+ oi <- parseOriginatorInfo (Container Context 0) <|> return mempty+ ris <- onNextContainer Set parse+ (ct, params, ec) <- parseEncryptedContentInfo+ aAttrs <- parseAttributes (Container Context 1)+ OctetString tag <- getNext+ uAttrs <- parseAttributes (Container Context 2)+ return AuthEnvelopedData { aeOriginatorInfo = oi+ , aeContentType = ct+ , aeRecipientInfos = ris+ , aeContentEncryptionParams = params+ , aeEncryptedContent = ec+ , aeAuthAttrs = aAttrs+ , aeMAC = AuthTag $ convert tag+ , aeUnauthAttrs = uAttrs+ }++-- | Return the DER encoding of the attributes as required for AAD.+encodeAuthAttrs :: [Attribute] -> ByteString+encodeAuthAttrs [] = mempty+encodeAuthAttrs l = encodeASN1S $ asn1Container Set (asn1s l)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Authenticated.hs view
@@ -0,0 +1,99 @@+-- |+-- Module : Crypto.Store.CMS.Authenticated+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Authenticated+ ( AuthenticatedData(..)+ ) where++import Control.Applicative+import Control.Monad++import Data.ASN1.Types+import qualified Data.ByteArray as B++import Crypto.Cipher.Types++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.OriginatorInfo+import Crypto.Store.CMS.Signed+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | Authenticated content information.+data AuthenticatedData content = AuthenticatedData+ { adOriginatorInfo :: OriginatorInfo+ -- ^ Optional information about the originator+ , adRecipientInfos :: [RecipientInfo]+ -- ^ Information for recipients, allowing to authenticate the content+ , adMACAlgorithm :: MACAlgorithm+ -- ^ MAC algorithm+ , adDigestAlgorithm :: Maybe DigestAlgorithm+ -- ^ Optional digest algorithm+ , adContentType :: ContentType+ -- ^ Inner content type+ , adEncapsulatedContent :: content+ -- ^ Encapsulated content+ , adAuthAttrs :: [Attribute]+ -- ^ Optional authenticated attributes+ , adMAC :: MessageAuthenticationCode+ -- ^ Message authentication code+ , adUnauthAttrs :: [Attribute]+ -- ^ Optional unauthenticated attributes+ }+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P (AuthenticatedData (Encap EncapsulatedContent)) where+ asn1s AuthenticatedData{..} =+ asn1Container Sequence (ver . oi . ris . alg . dig . ci . aa . tag . ua)+ where+ ver = gIntVal v+ ris = asn1Container Set (asn1s adRecipientInfos)+ alg = algorithmASN1S Sequence adMACAlgorithm+ dig = algorithmMaybeASN1S (Container Context 1) adDigestAlgorithm+ ci = encapsulatedContentInfoASN1S adContentType adEncapsulatedContent+ aa = attributesASN1S(Container Context 2) adAuthAttrs+ tag = gOctetString (B.convert adMAC)+ ua = attributesASN1S (Container Context 3) adUnauthAttrs++ oi | adOriginatorInfo == mempty = id+ | otherwise = originatorInfoASN1S (Container Context 0) adOriginatorInfo++ v | hasChoiceOther adOriginatorInfo = 3+ | otherwise = 0++instance ParseASN1Object [ASN1Event] (AuthenticatedData (Encap EncapsulatedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v `notElem` [0, 1, 3]) $+ throwParseError ("AuthenticatedData: parsed invalid version: " ++ show v)+ oi <- parseOriginatorInfo (Container Context 0) <|> return mempty+ ris <- onNextContainer Set parse+ alg <- parseAlgorithm Sequence+ dig <- parseAlgorithmMaybe (Container Context 1)+ (ct, bs) <- parseEncapsulatedContentInfo+ aAttrs <- parseAttributes (Container Context 2)+ OctetString tag <- getNext+ uAttrs <- parseAttributes (Container Context 3)+ return AuthenticatedData { adOriginatorInfo = oi+ , adRecipientInfos = ris+ , adMACAlgorithm = alg+ , adDigestAlgorithm = dig+ , adContentType = ct+ , adEncapsulatedContent = bs+ , adAuthAttrs = aAttrs+ , adMAC = AuthTag $ B.convert tag+ , adUnauthAttrs = uAttrs+ }
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Digested.hs view
@@ -0,0 +1,82 @@+-- |+-- Module : Crypto.Store.CMS.Digested+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Digested+ ( DigestedData(..)+ ) where++import Control.Monad++import Data.ASN1.Types+import qualified Data.ByteArray as B++import Crypto.Hash hiding (MD5)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Signed+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | Digested content information.+data DigestedData content = forall hashAlg. HashAlgorithm hashAlg => DigestedData+ { ddDigestAlgorithm :: DigestProxy hashAlg -- ^ Digest algorithm+ , ddContentType :: ContentType -- ^ Inner content type+ , ddEncapsulatedContent :: content -- ^ Encapsulated content+ , ddDigest :: Digest hashAlg -- ^ Digest value+ }++instance Show content => Show (DigestedData content) where+ showsPrec d DigestedData{..} = showParen (d > 10) $+ showString "DigestedData "+ . showString "{ ddDigestAlgorithm = " . shows ddDigestAlgorithm+ . showString ", ddContentType = " . shows ddContentType+ . showString ", ddEncapsulatedContent = " . shows ddEncapsulatedContent+ . showString ", ddDigest = " . shows ddDigest+ . showString " }"++instance Eq content => Eq (DigestedData content) where+ DigestedData a1 t1 e1 d1 == DigestedData a2 t2 e2 d2 =+ DigestAlgorithm a1 == DigestAlgorithm a2 && d1 `B.eq` d2 && t1 == t2 && e1 == e2++instance ASN1Elem e => ProduceASN1Object e (DigestedData (Encap EncapsulatedContent)) where+ asn1s DigestedData{..} =+ asn1Container Sequence (ver . alg . ci . dig)+ where+ v = if ddContentType == DataType then 0 else 2+ d = DigestAlgorithm ddDigestAlgorithm++ ver = gIntVal v+ alg = algorithmASN1S Sequence d+ ci = encapsulatedContentInfoASN1S ddContentType ddEncapsulatedContent+ dig = gOctetString (B.convert ddDigest)++instance Monoid e => ParseASN1Object e (DigestedData (Encap EncapsulatedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v /= 0 && v /= 2) $+ throwParseError ("DigestedData: parsed invalid version: " ++ show v)+ alg <- parseAlgorithm Sequence+ (ct, bs) <- parseEncapsulatedContentInfo+ OctetString digValue <- getNext+ case alg of+ DigestAlgorithm digAlg ->+ case digestFromByteString digValue of+ Nothing -> throwParseError "DigestedData: parsed invalid digest"+ Just d ->+ return DigestedData { ddDigestAlgorithm = digAlg+ , ddContentType = ct+ , ddEncapsulatedContent = bs+ , ddDigest = d+ }
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Encrypted.hs view
@@ -0,0 +1,103 @@+-- |+-- Module : Crypto.Store.CMS.Encrypted+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Encrypted+ ( EncryptedContent+ , ContentEncryptionKey+ , EncryptedData(..)+ , encryptedContentInfoASN1S+ , parseEncryptedContentInfo+ ) where++import Control.Applicative+import Control.Monad++import Data.ASN1.Types+import qualified Data.ByteString as B++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | Key used for content encryption.+type ContentEncryptionKey = B.ByteString++-- | Encrypted content.+type EncryptedContent = B.ByteString++-- | Encrypted content information.+data EncryptedData content = EncryptedData+ { edContentType :: ContentType+ -- ^ Inner content type+ , edContentEncryptionParams :: ContentEncryptionParams+ -- ^ Encryption algorithm+ , edEncryptedContent :: content+ -- ^ Encrypted content info+ , edUnprotectedAttrs :: [Attribute]+ -- ^ Optional unprotected attributes+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e (EncryptedData (Encap EncryptedContent)) where+ asn1s EncryptedData{..} =+ asn1Container Sequence (ver . eci . ua)+ where+ ver = gIntVal (if null edUnprotectedAttrs then 0 else 2)+ eci = encryptedContentInfoASN1S+ (edContentType, edContentEncryptionParams, edEncryptedContent)+ ua = attributesASN1S (Container Context 1) edUnprotectedAttrs++instance Monoid e => ParseASN1Object e (EncryptedData (Encap EncryptedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v /= 0 && v /= 2) $+ throwParseError ("EncryptedData: parsed invalid version: " ++ show v)+ (ct, params, ec) <- parseEncryptedContentInfo+ attrs <- parseAttributes (Container Context 1)+ return EncryptedData { edContentType = ct+ , edContentEncryptionParams = params+ , edEncryptedContent = ec+ , edUnprotectedAttrs = attrs+ }++-- | Generate ASN.1 for EncryptedContentInfo.+encryptedContentInfoASN1S :: (ASN1Elem e, ProduceASN1Object e alg)+ => (ContentType, alg, Encap EncryptedContent) -> ASN1Stream e+encryptedContentInfoASN1S (ct, alg, ec) =+ asn1Container Sequence (ct' . alg' . ec')+ where+ ct' = gOID (getObjectID ct)+ alg' = asn1s alg+ ec' = encapsulatedASN1S (Container Context 0) ec++encapsulatedASN1S :: ASN1Elem e+ => ASN1ConstructionType -> Encap EncryptedContent -> ASN1Stream e+encapsulatedASN1S _ Detached = id+encapsulatedASN1S ty (Attached bs) = asn1Container ty (gOctetString bs)++-- | Parse EncryptedContentInfo from ASN.1.+parseEncryptedContentInfo :: ParseASN1Object e alg+ => ParseASN1 e (ContentType, alg, Encap EncryptedContent)+parseEncryptedContentInfo = onNextContainer Sequence $ do+ OID oid <- getNext+ alg <- parse+ b <- hasNext+ ec <- if b then Attached <$> parseEncryptedContent else return Detached+ withObjectID "content type" oid $ \ct -> return (ct, alg, ec)+ where+ parseEncryptedContent = parseWrapped <|> parsePrimitive+ parseWrapped = onNextContainer (Container Context 0) parseOctetStrings+ parsePrimitive = do Other Context 0 bs <- getNext; return bs
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Enveloped.hs view
@@ -0,0 +1,631 @@+-- |+-- Module : Crypto.Store.CMS.Enveloped+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Enveloped+ ( EncryptedKey+ , UserKeyingMaterial+ , RecipientInfo(..)+ , EnvelopedData(..)+ , ProducerOfRI+ , ConsumerOfRI+ -- * Key Transport recipients+ , KTRecipientInfo(..)+ , RecipientIdentifier(..)+ , IssuerAndSerialNumber(..)+ , forKeyTransRecipient+ , withRecipientKeyTrans+ -- * Key Agreement recipients+ , KARecipientInfo(..)+ , OriginatorIdentifierOrKey(..)+ , OriginatorPublicKey+ , RecipientEncryptedKey(..)+ , KeyAgreeRecipientIdentifier(..)+ , forKeyAgreeRecipient+ , withRecipientKeyAgree+ -- * Key Encryption Key recipients+ , KeyEncryptionKey+ , KEKRecipientInfo(..)+ , KeyIdentifier(..)+ , OtherKeyAttribute(..)+ , forKeyRecipient+ , withRecipientKey+ -- * Password recipients+ , Password+ , PasswordRecipientInfo(..)+ , forPasswordRecipient+ , withRecipientPassword+ ) where++import Control.Applicative+import Control.Monad++import Data.ASN1.BitArray+import Data.ASN1.Types+import Data.ByteString (ByteString)+import Data.List (find)+import Data.Maybe (fromMaybe)+import Data.X509++import Time.Types++import Crypto.Random (MonadRandom)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.OriginatorInfo+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util+import Crypto.Store.Error++-- | Encrypted key.+type EncryptedKey = ByteString++-- | User keying material.+type UserKeyingMaterial = ByteString++-- | Key used for key encryption.+type KeyEncryptionKey = ByteString++-- | A password stored as a sequence of UTF-8 bytes.+--+-- Some key-derivation functions add restrictions to what characters+-- are supported.+--+-- Beware: 'Data.String.fromString' truncates multi-byte characters.+-- If the string may contain non-ASCII characters, prefer instead+-- @'Crypto.Store.PKCS5.fromProtectionPassword' . 'Data.String.fromString'@.+type Password = ByteString++-- | Union type related to identification of the recipient.+data RecipientIdentifier+ = RecipientIASN IssuerAndSerialNumber -- ^ Issuer and Serial Number+ | RecipientSKI ByteString -- ^ Subject Key Identifier+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e RecipientIdentifier where+ asn1s (RecipientIASN iasn) = asn1s iasn+ asn1s (RecipientSKI ski) = asn1Container (Container Context 0)+ (gOctetString ski)++instance Monoid e => ParseASN1Object e RecipientIdentifier where+ parse = parseIASN <|> parseSKI+ where parseIASN = RecipientIASN <$> parse+ parseSKI = RecipientSKI <$>+ onNextContainer (Container Context 0) parseOctetStringPrim++getKTVersion :: RecipientIdentifier -> Integer+getKTVersion (RecipientIASN _) = 0+getKTVersion (RecipientSKI _) = 2++-- | Identification of a certificate using the issuer DN and serial number.+data IssuerAndSerialNumber = IssuerAndSerialNumber+ { iasnIssuer :: DistinguishedName+ -- ^ Distinguished name of the certificate issuer+ , iasnSerial :: Integer+ -- ^ Issuer-specific certificate serial number+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e IssuerAndSerialNumber where+ asn1s IssuerAndSerialNumber{..} =+ asn1Container Sequence (asn1s iasnIssuer . gIntVal iasnSerial)++instance Monoid e => ParseASN1Object e IssuerAndSerialNumber where+ parse = onNextContainer Sequence $ do+ i <- parse+ IntVal s <- getNext+ return IssuerAndSerialNumber { iasnIssuer = i+ , iasnSerial = s+ }++idEcPublicKey :: OID+idEcPublicKey = [1,2,840,10045,2,1]++-- | Originator public key used for key-agreement. Contrary to 'PubKey' the+-- domain parameters are not used and may be left empty.+data OriginatorPublicKey = OriginatorPublicKeyEC [ASN1] BitArray+ deriving (Show,Eq)++originatorPublicKeyASN1S :: ASN1Elem e+ => ASN1ConstructionType+ -> OriginatorPublicKey+ -> ASN1Stream e+originatorPublicKeyASN1S ty (OriginatorPublicKeyEC asn1 ba) =+ asn1Container ty (alg . gBitString ba)+ where+ alg = asn1Container Sequence (gOID idEcPublicKey . gMany asn1)++parseOriginatorPublicKey :: Monoid e+ => ASN1ConstructionType+ -> ParseASN1 e OriginatorPublicKey+parseOriginatorPublicKey ty =+ onNextContainer ty $ do+ asn1 <- onNextContainer Sequence $ do+ OID oid <- getNext+ guard (oid == idEcPublicKey)+ getMany getNext+ BitString ba <- getNext+ return (OriginatorPublicKeyEC asn1 ba)++-- | Union type related to identification of the originator.+data OriginatorIdentifierOrKey+ = OriginatorIASN IssuerAndSerialNumber -- ^ Issuer and Serial Number+ | OriginatorSKI ByteString -- ^ Subject Key Identifier+ | OriginatorPublic OriginatorPublicKey -- ^ Anonymous public key+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e OriginatorIdentifierOrKey where+ asn1s (OriginatorIASN iasn) = asn1s iasn+ asn1s (OriginatorSKI ski) = asn1Container (Container Context 0)+ (gOctetString ski)+ asn1s (OriginatorPublic pub) =+ originatorPublicKeyASN1S (Container Context 1) pub++instance Monoid e => ParseASN1Object e OriginatorIdentifierOrKey where+ parse = parseIASN <|> parseSKI <|> parsePublic+ where parseIASN = OriginatorIASN <$> parse+ parseSKI = OriginatorSKI <$>+ onNextContainer (Container Context 0) parseOctetStringPrim+ parsePublic = OriginatorPublic <$>+ parseOriginatorPublicKey (Container Context 1)++-- | Union type related to identification of a key-agreement recipient.+data KeyAgreeRecipientIdentifier+ = KeyAgreeRecipientIASN IssuerAndSerialNumber -- ^ Issuer and Serial Number+ | KeyAgreeRecipientKI KeyIdentifier -- ^ Key identifier+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e KeyAgreeRecipientIdentifier where+ asn1s (KeyAgreeRecipientIASN iasn) = asn1s iasn+ asn1s (KeyAgreeRecipientKI ki) = asn1Container (Container Context 0)+ (asn1s ki)++instance Monoid e => ParseASN1Object e KeyAgreeRecipientIdentifier where+ parse = parseIASN <|> parseKI+ where parseIASN = KeyAgreeRecipientIASN <$> parse+ parseKI = KeyAgreeRecipientKI <$>+ onNextContainer (Container Context 0) parse++-- | Encrypted key for a recipient in a key-agreement RI.+data RecipientEncryptedKey = RecipientEncryptedKey+ { rekRid :: KeyAgreeRecipientIdentifier -- ^ identifier of recipient+ , rekEncryptedKey :: EncryptedKey -- ^ encrypted content-encryption key+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e RecipientEncryptedKey where+ asn1s RecipientEncryptedKey{..} = asn1Container Sequence (rid . ek)+ where rid = asn1s rekRid+ ek = gOctetString rekEncryptedKey++instance Monoid e => ParseASN1Object e RecipientEncryptedKey where+ parse = onNextContainer Sequence $ do+ rid <- parse+ OctetString ek <- getNext+ return RecipientEncryptedKey { rekRid = rid, rekEncryptedKey = ek }++findRecipientEncryptedKey :: SignedCertificate+ -> [RecipientEncryptedKey]+ -> Maybe EncryptedKey+findRecipientEncryptedKey cert list = rekEncryptedKey <$> find fn list+ where+ c = signedObject (getSigned cert)+ matchIASN iasn =+ (iasnIssuer iasn, iasnSerial iasn) == (certIssuerDN c, certSerial c)+ matchSKI ski =+ case extensionGet (certExtensions c) of+ Just (ExtSubjectKeyId idBs) -> idBs == ski+ Nothing -> False+ fn rek = case rekRid rek of+ KeyAgreeRecipientIASN iasn -> matchIASN iasn+ KeyAgreeRecipientKI ki -> matchSKI (keyIdentifier ki)++-- | Additional information in a 'KeyIdentifier'.+data OtherKeyAttribute = OtherKeyAttribute+ { keyAttrId :: OID -- ^ attribute identifier+ , keyAttr :: [ASN1] -- ^ attribute value+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e OtherKeyAttribute where+ asn1s OtherKeyAttribute{..} = asn1Container Sequence (attrId . attr)+ where attrId = gOID keyAttrId+ attr = gMany keyAttr++instance Monoid e => ParseASN1Object e OtherKeyAttribute where+ parse = onNextContainer Sequence $ do+ OID attrId <- getNext+ attr <- getMany getNext+ return OtherKeyAttribute { keyAttrId = attrId, keyAttr = attr }++-- | Key identifier and optional attributes.+data KeyIdentifier = KeyIdentifier+ { keyIdentifier :: ByteString -- ^ identifier of the key+ , keyDate :: Maybe DateTime -- ^ optional timestamp+ , keyOther :: Maybe OtherKeyAttribute -- ^ optional information+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e KeyIdentifier where+ asn1s KeyIdentifier{..} = asn1Container Sequence (keyId . date . other)+ where+ keyId = gOctetString keyIdentifier+ date = optASN1S keyDate $ \v -> gASN1Time TimeGeneralized v Nothing+ other = optASN1S keyOther asn1s++instance Monoid e => ParseASN1Object e KeyIdentifier where+ parse = onNextContainer Sequence $ do+ OctetString keyId <- getNext+ date <- getNextMaybe dateTimeOrNothing+ b <- hasNext+ other <- if b then Just <$> parse else return Nothing+ return KeyIdentifier { keyIdentifier = keyId+ , keyDate = date+ , keyOther = other+ }++-- | Recipient using key transport.+data KTRecipientInfo = KTRecipientInfo+ { ktRid :: RecipientIdentifier -- ^ identifier of recipient+ , ktKeyTransportParams :: KeyTransportParams -- ^ key transport algorithm+ , ktEncryptedKey :: EncryptedKey -- ^ encrypted content-encryption key+ }+ deriving (Show,Eq)++-- | Recipient using key agreement.+data KARecipientInfo = KARecipientInfo+ { kaOriginator :: OriginatorIdentifierOrKey -- ^ identifier of orginator or anonymous key+ , kaUkm :: Maybe UserKeyingMaterial -- ^ user keying material+ , kaKeyAgreementParams :: KeyAgreementParams -- ^ key agreement algorithm+ , kaRecipientEncryptedKeys :: [RecipientEncryptedKey] -- ^ encrypted content-encryption key for one or multiple recipients+ }+ deriving (Show,Eq)++-- | Recipient using key encryption.+data KEKRecipientInfo = KEKRecipientInfo+ { kekId :: KeyIdentifier -- ^ identifier of key encryption key+ , kekKeyEncryptionParams :: KeyEncryptionParams -- ^ key encryption algorithm+ , kekEncryptedKey :: EncryptedKey -- ^ encrypted content-encryption key+ }+ deriving (Show,Eq)++-- | Recipient using password-based protection.+data PasswordRecipientInfo = PasswordRecipientInfo+ { priKeyDerivationFunc :: KeyDerivationFunc -- ^ function to derive key+ , priKeyEncryptionParams :: KeyEncryptionParams -- ^ key encryption algorithm+ , priEncryptedKey :: EncryptedKey -- ^ encrypted content-encryption key+ }+ deriving (Show,Eq)++-- | Information for a recipient of an 'EnvelopedData'. An element contains+-- the content-encryption key in encrypted form.+data RecipientInfo = KTRI KTRecipientInfo+ -- ^ Recipient using key transport+ | KARI KARecipientInfo+ -- ^ Recipient using key agreement+ | KEKRI KEKRecipientInfo+ -- ^ Recipient using key encryption+ | PasswordRI PasswordRecipientInfo+ -- ^ Recipient using password-based protection+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e RecipientInfo where+ asn1s (KTRI KTRecipientInfo{..}) =+ asn1Container Sequence (ver . rid . ktp . ek)+ where+ ver = gIntVal (getKTVersion ktRid)+ rid = asn1s ktRid+ ktp = algorithmASN1S Sequence ktKeyTransportParams+ ek = gOctetString ktEncryptedKey++ asn1s (KARI KARecipientInfo{..}) =+ asn1Container (Container Context 1) (ver . ori . ukm . kap . reks)+ where+ ver = gIntVal 3+ ori = asn1Container (Container Context 0) (asn1s kaOriginator)+ kap = algorithmASN1S Sequence kaKeyAgreementParams+ reks = asn1Container Sequence (asn1s kaRecipientEncryptedKeys)++ ukm = case kaUkm of+ Nothing -> id+ Just bs -> asn1Container (Container Context 1) (gOctetString bs)++ asn1s (KEKRI KEKRecipientInfo{..}) =+ asn1Container (Container Context 2) (ver . kid . kep . ek)+ where+ ver = gIntVal 4+ kid = asn1s kekId+ kep = algorithmASN1S Sequence kekKeyEncryptionParams+ ek = gOctetString kekEncryptedKey++ asn1s (PasswordRI PasswordRecipientInfo{..}) =+ asn1Container (Container Context 3) (ver . kdf . kep . ek)+ where+ ver = gIntVal 0+ kdf = algorithmASN1S (Container Context 0) priKeyDerivationFunc+ kep = algorithmASN1S Sequence priKeyEncryptionParams+ ek = gOctetString priEncryptedKey++instance Monoid e => ParseASN1Object e RecipientInfo where+ parse = do+ c <- onNextContainerMaybe Sequence parseKT+ `orElse` onNextContainerMaybe (Container Context 1) parseKA+ `orElse` onNextContainerMaybe (Container Context 2) parseKEK+ `orElse` onNextContainerMaybe (Container Context 3) parsePassword+ case c of+ Just val -> return val+ Nothing -> throwParseError "RecipientInfo: unable to parse"+ where+ parseKT = KTRI <$> do+ IntVal v <- getNext+ when (v `notElem` [0, 2]) $+ throwParseError ("RecipientInfo: parsed invalid KT version: " ++ show v)+ rid <- parse+ ktp <- parseAlgorithm Sequence+ OctetString ek <- getNext+ return KTRecipientInfo { ktRid = rid+ , ktKeyTransportParams = ktp+ , ktEncryptedKey = ek+ }++ parseKA = KARI <$> do+ IntVal 3 <- getNext+ ori <- onNextContainer (Container Context 0) parse+ ukm <- onNextContainerMaybe (Container Context 1) $+ do { OctetString bs <- getNext; return bs }+ kap <- parseAlgorithm Sequence+ reks <- onNextContainer Sequence parse+ return KARecipientInfo { kaOriginator = ori+ , kaUkm = ukm+ , kaKeyAgreementParams = kap+ , kaRecipientEncryptedKeys = reks+ }++ parseKEK = KEKRI <$> do+ IntVal 4 <- getNext+ kid <- parse+ kep <- parseAlgorithm Sequence+ OctetString ek <- getNext+ return KEKRecipientInfo { kekId = kid+ , kekKeyEncryptionParams = kep+ , kekEncryptedKey = ek+ }++ parsePassword = PasswordRI <$> do+ IntVal 0 <- getNext+ kdf <- parseAlgorithm (Container Context 0)+ kep <- parseAlgorithm Sequence+ OctetString ek <- getNext+ return PasswordRecipientInfo { priKeyDerivationFunc = kdf+ , priKeyEncryptionParams = kep+ , priEncryptedKey = ek+ }++isVersion0 :: RecipientInfo -> Bool+isVersion0 (KTRI x) = getKTVersion (ktRid x) == 0+isVersion0 (KARI _) = False -- because version is always 3+isVersion0 (KEKRI _) = False -- because version is always 4+isVersion0 (PasswordRI _) = True -- because version is always 0++isPwriOri :: RecipientInfo -> Bool+isPwriOri (KTRI _) = False+isPwriOri (KARI _) = False+isPwriOri (KEKRI _) = False+isPwriOri (PasswordRI _) = True++-- | Enveloped content information.+data EnvelopedData content = EnvelopedData+ { evOriginatorInfo :: OriginatorInfo+ -- ^ Optional information about the originator+ , evRecipientInfos :: [RecipientInfo]+ -- ^ Information for recipients, allowing to decrypt the content+ , evContentType :: ContentType+ -- ^ Inner content type+ , evContentEncryptionParams :: ContentEncryptionParams+ -- ^ Encryption algorithm+ , evEncryptedContent :: content+ -- ^ Encrypted content info+ , evUnprotectedAttrs :: [Attribute]+ -- ^ Optional unprotected attributes+ }+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P (EnvelopedData (Encap EncryptedContent)) where+ asn1s EnvelopedData{..} =+ asn1Container Sequence (ver . oi . ris . eci . ua)+ where+ ver = gIntVal v+ ris = asn1Container Set (asn1s evRecipientInfos)+ eci = encryptedContentInfoASN1S+ (evContentType, evContentEncryptionParams, evEncryptedContent)+ ua = attributesASN1S (Container Context 1) evUnprotectedAttrs++ oi | evOriginatorInfo == mempty = id+ | otherwise = originatorInfoASN1S (Container Context 0) evOriginatorInfo++ v | hasChoiceOther evOriginatorInfo = 4+ | any isPwriOri evRecipientInfos = 3+ | evOriginatorInfo /= mempty = 2+ | not (null evUnprotectedAttrs) = 2+ | all isVersion0 evRecipientInfos = 0+ | otherwise = 2++instance ParseASN1Object [ASN1Event] (EnvelopedData (Encap EncryptedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v > 4) $+ throwParseError ("EnvelopedData: parsed invalid version: " ++ show v)+ oi <- parseOriginatorInfo (Container Context 0) <|> return mempty+ ris <- onNextContainer Set parse+ (ct, params, ec) <- parseEncryptedContentInfo+ attrs <- parseAttributes (Container Context 1)+ return EnvelopedData { evOriginatorInfo = oi+ , evRecipientInfos = ris+ , evContentType = ct+ , evContentEncryptionParams = params+ , evEncryptedContent = ec+ , evUnprotectedAttrs = attrs+ }++-- | Function able to produce a 'RecipientInfo'.+type ProducerOfRI m = ContentEncryptionKey -> m (Either StoreError RecipientInfo)++-- | Function able to consume a 'RecipientInfo'.+type ConsumerOfRI m = RecipientInfo -> m (Either StoreError ContentEncryptionKey)++-- | Generate a Key Transport recipient from a certificate and+-- desired algorithm. The recipient will contain certificate identifier.+--+-- This function can be used as parameter to 'Crypto.Store.CMS.envelopData'.+forKeyTransRecipient :: MonadRandom m+ => SignedCertificate -> KeyTransportParams -> ProducerOfRI m+forKeyTransRecipient cert params inkey = do+ ek <- transportEncrypt params (certPubKey obj) inkey+ return (KTRI . build <$> ek)+ where+ obj = signedObject (getSigned cert)+ isn = IssuerAndSerialNumber (certIssuerDN obj) (certSerial obj)++ build ek = KTRecipientInfo+ { ktRid = RecipientIASN isn+ , ktKeyTransportParams = params+ , ktEncryptedKey = ek+ }++-- | Use a Key Transport recipient, knowing the private key.+--+-- This function can be used as parameter to+-- 'Crypto.Store.CMS.openEnvelopedData'.+withRecipientKeyTrans :: MonadRandom m => PrivKey -> ConsumerOfRI m+withRecipientKeyTrans privKey (KTRI KTRecipientInfo{..}) =+ transportDecrypt ktKeyTransportParams privKey ktEncryptedKey+withRecipientKeyTrans _ _ = pure (Left RecipientTypeMismatch)++-- | Generate a Key Agreement recipient from a certificate and+-- desired algorithm. The recipient info will contain an ephemeral public key.+--+-- This function can be used as parameter to 'Crypto.Store.CMS.envelopData'.+--+-- To avoid decreasing the security strength, Key Encryption parameters should+-- use a key size equal or greater than the content encryption key.+forKeyAgreeRecipient :: MonadRandom m+ => SignedCertificate -> KeyAgreementParams -> ProducerOfRI m+forKeyAgreeRecipient cert params inkey = do+ ephemeral <- ecdhGenerate (certPubKey obj)+ case ephemeral of+ Right pair -> do+ let pt = ecdhPublic pair+ aPub = OriginatorPublicKeyEC [] (toBitArray pt 0)+ ek <- ecdhEncrypt params Nothing pair inkey+ return (KARI . build aPub <$> ek)+ Left err -> return $ Left err+ where+ obj = signedObject (getSigned cert)+ isn = IssuerAndSerialNumber (certIssuerDN obj) (certSerial obj)++ makeREK ek = RecipientEncryptedKey+ { rekRid = KeyAgreeRecipientIASN isn+ , rekEncryptedKey = ek+ }++ build aPub ek =+ KARecipientInfo+ { kaOriginator = OriginatorPublic aPub+ , kaUkm = Nothing+ , kaKeyAgreementParams = params+ , kaRecipientEncryptedKeys = [ makeREK ek ]+ }++-- | Use a Key Agreement recipient, knowing the recipient private key. The+-- recipient certificate is also required to locate which encrypted key to use.+--+-- This function can be used as parameter to+-- 'Crypto.Store.CMS.openEnvelopedData'.+withRecipientKeyAgree :: MonadRandom m => PrivKey -> SignedCertificate -> ConsumerOfRI m+withRecipientKeyAgree priv cert (KARI KARecipientInfo{..}) =+ case kaOriginator of+ OriginatorPublic (OriginatorPublicKeyEC _ ba) ->+ case findRecipientEncryptedKey cert kaRecipientEncryptedKeys of+ Nothing -> pure (Left RecipientKeyNotFound)+ Just ek ->+ let pub = bitArrayGetData ba+ in pure (ecdhDecrypt kaKeyAgreementParams kaUkm priv pub ek)+ _ -> pure (Left UnsupportedOriginatorFormat)+withRecipientKeyAgree _ _ _ = pure (Left RecipientTypeMismatch)++-- | Generate a Key Encryption Key recipient from a key encryption key and+-- desired algorithm. The recipient may identify the KEK that was used with+-- the supplied identifier.+--+-- This function can be used as parameter to 'Crypto.Store.CMS.envelopData'.+--+-- To avoid decreasing the security strength, Key Encryption parameters should+-- use a key size equal or greater than the content encryption key.+forKeyRecipient :: MonadRandom m+ => KeyEncryptionKey+ -> KeyIdentifier+ -> KeyEncryptionParams+ -> ProducerOfRI m+forKeyRecipient key kid params inkey = do+ ek <- keyEncrypt key params inkey+ return (KEKRI . build <$> ek)+ where+ build ek = KEKRecipientInfo+ { kekId = kid+ , kekKeyEncryptionParams = params+ , kekEncryptedKey = ek+ }++-- | Use a Key Encryption Key recipient, knowing the key encryption key.+--+-- This function can be used as parameter to+-- 'Crypto.Store.CMS.openEnvelopedData'.+withRecipientKey :: Applicative f => KeyEncryptionKey -> ConsumerOfRI f+withRecipientKey key (KEKRI KEKRecipientInfo{..}) =+ pure (keyDecrypt key kekKeyEncryptionParams kekEncryptedKey)+withRecipientKey _ _ = pure (Left RecipientTypeMismatch)++-- | Generate a password recipient from a password.+--+-- This function can be used as parameter to 'Crypto.Store.CMS.envelopData'.+forPasswordRecipient :: MonadRandom m+ => Password+ -> KeyDerivationFunc+ -> KeyEncryptionParams+ -> ProducerOfRI m+forPasswordRecipient pwd kdf params inkey = do+ ek <- keyEncrypt derived params inkey+ return (PasswordRI . build <$> ek)+ where+ derived = kdfDerive kdf len pwd :: EncryptedKey+ len = fromMaybe (getMaximumKeySize params) (kdfKeyLength kdf)+ build ek = PasswordRecipientInfo+ { priKeyDerivationFunc = kdf+ , priKeyEncryptionParams = params+ , priEncryptedKey = ek+ }++-- | Use a password recipient, knowing the password.+--+-- This function can be used as parameter to+-- 'Crypto.Store.CMS.openEnvelopedData'.+withRecipientPassword :: Applicative f => Password -> ConsumerOfRI f+withRecipientPassword pwd (PasswordRI PasswordRecipientInfo{..}) =+ pure (keyDecrypt derived priKeyEncryptionParams priEncryptedKey)+ where+ derived = kdfDerive priKeyDerivationFunc len pwd :: EncryptedKey+ len = fromMaybe (getMaximumKeySize priKeyEncryptionParams)+ (kdfKeyLength priKeyDerivationFunc)+withRecipientPassword _ _ = pure (Left RecipientTypeMismatch)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Info.hs view
@@ -0,0 +1,194 @@+-- |+-- Module : Crypto.Store.CMS.Info+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- CMS content information.+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Crypto.Store.CMS.Info+ ( ContentInfo(..)+ , getContentType+ , Encapsulates+ , isAttached+ , fromAttached+ , toAttachedCI+ , isDetached+ , fromDetached+ , toDetachedCI+ ) where++import Control.Monad.Fail (MonadFail)++import Data.ASN1.Types+import Data.ByteString (ByteString)+import Data.Functor.Identity+import Data.Maybe (isJust, isNothing)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Authenticated+import Crypto.Store.CMS.AuthEnveloped+import Crypto.Store.CMS.Digested+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.Signed+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util++-- | Get the type of a content info.+getContentType :: ContentInfo -> ContentType+getContentType (DataCI _) = DataType+getContentType (SignedDataCI _) = SignedDataType+getContentType (EnvelopedDataCI _) = EnvelopedDataType+getContentType (DigestedDataCI _) = DigestedDataType+getContentType (EncryptedDataCI _) = EncryptedDataType+getContentType (AuthenticatedDataCI _) = AuthenticatedDataType+getContentType (AuthEnvelopedDataCI _) = AuthEnvelopedDataType+++-- ContentInfo++-- | CMS content information.+data ContentInfo = DataCI ByteString+ -- ^ Arbitrary octet string+ | SignedDataCI (SignedData (Encap EncapsulatedContent))+ -- ^ Signed content info+ | EnvelopedDataCI (EnvelopedData (Encap EncryptedContent))+ -- ^ Enveloped content info+ | DigestedDataCI (DigestedData (Encap EncapsulatedContent))+ -- ^ Content info with associated digest+ | EncryptedDataCI (EncryptedData (Encap EncryptedContent))+ -- ^ Encrypted content info+ | AuthenticatedDataCI (AuthenticatedData (Encap EncapsulatedContent))+ -- ^ Authenticatedcontent info+ | AuthEnvelopedDataCI (AuthEnvelopedData (Encap EncryptedContent))+ -- ^ Authenticated-enveloped content info+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P ContentInfo where+ asn1s ci = asn1Container Sequence (oid . cont)+ where oid = gOID $ getObjectID $ getContentType ci+ cont = asn1Container (Container Context 0) inner+ inner =+ case ci of+ DataCI bs -> dataASN1S bs+ SignedDataCI ed -> asn1s ed+ EnvelopedDataCI ed -> asn1s ed+ DigestedDataCI dd -> asn1s dd+ EncryptedDataCI ed -> asn1s ed+ AuthenticatedDataCI ad -> asn1s ad+ AuthEnvelopedDataCI ae -> asn1s ae++instance ParseASN1Object [ASN1Event] ContentInfo where+ parse =+ onNextContainer Sequence $ do+ OID oid <- getNext+ withObjectID "content type" oid $ \ct ->+ onNextContainer (Container Context 0) (parseInner ct)+ where+ parseInner DataType = DataCI <$> parseData+ parseInner SignedDataType = SignedDataCI <$> parse+ parseInner EnvelopedDataType = EnvelopedDataCI <$> parse+ parseInner DigestedDataType = DigestedDataCI <$> parse+ parseInner EncryptedDataType = EncryptedDataCI <$> parse+ parseInner AuthenticatedDataType = AuthenticatedDataCI <$> parse+ parseInner AuthEnvelopedDataType = AuthEnvelopedDataCI <$> parse+++-- Data++dataASN1S :: ASN1Elem e => ByteString -> ASN1Stream e+dataASN1S = gOctetString++parseData :: Monoid e => ParseASN1 e ByteString+parseData = parseOctetString++-- Encapsulation++-- | Class of data structures with inner content that may be stored externally.+-- This class has instances for each CMS content type containing other+-- encapsulated or encrypted content info.+--+-- Functions 'fromAttached' and 'fromDetached' are used to introspect+-- encapsulation state (attached or detached), and recover a data structure with+-- actionable content.+--+-- Functions 'toAttachedCI' and 'toDetachedCI' are needed to decide about the+-- outer encapsulation state and build a 'ContentInfo'.+class Encapsulates struct where+ lens :: Functor f => (a -> f b) -> struct a -> f (struct b)+ toCI :: struct (Encap ByteString) -> ContentInfo++instance Encapsulates SignedData where+ lens f s = let g a = s { sdEncapsulatedContent = a }+ in fmap g (f $ sdEncapsulatedContent s)+ toCI = SignedDataCI++instance Encapsulates EnvelopedData where+ lens f s = let g a = s { evEncryptedContent = a }+ in fmap g (f $ evEncryptedContent s)+ toCI = EnvelopedDataCI++instance Encapsulates DigestedData where+ lens f s = let g a = s { ddEncapsulatedContent = a }+ in fmap g (f $ ddEncapsulatedContent s)+ toCI = DigestedDataCI++instance Encapsulates EncryptedData where+ lens f s = let g a = s { edEncryptedContent = a }+ in fmap g (f $ edEncryptedContent s)+ toCI = EncryptedDataCI++instance Encapsulates AuthenticatedData where+ lens f s = let g a = s { adEncapsulatedContent = a }+ in fmap g (f $ adEncapsulatedContent s)+ toCI = AuthenticatedDataCI++instance Encapsulates AuthEnvelopedData where+ lens f s = let g a = s { aeEncryptedContent = a }+ in fmap g (f $ aeEncryptedContent s)+ toCI = AuthEnvelopedDataCI++-- | Return 'True' when the encapsulated content is attached.+isAttached :: Encapsulates struct => struct (Encap a) -> Bool+isAttached = isJust . fromAttached++-- | Unwrap the encapsulation, assuming the inner content is inside the data+-- structure. The monadic computation fails if the content was detached.+fromAttached :: (MonadFail m, Encapsulates struct) => struct (Encap a) -> m (struct a)+fromAttached = lens (fromEncap err return)+ where err = fail "fromAttached: detached"++-- | Keep the content inside the data structure.+toAttached :: Encapsulates struct => struct a -> struct (Encap a)+toAttached = runIdentity . lens (Identity . Attached)++-- | Transform the data structure into a content info, keeping the encapsulated+-- content attached. May be applied to structures with 'EncapsulatedContent' or+-- 'EncryptedContent'.+toAttachedCI :: Encapsulates struct => struct ByteString -> ContentInfo+toAttachedCI = toCI . toAttached++-- | Return 'True' when the encapsulated content is detached.+isDetached :: Encapsulates struct => struct (Encap a) -> Bool+isDetached = isNothing . fromAttached++-- | Recover the original data structure from a detached encapsulation and the+-- external content. The monadic computation fails if the content was attached.+fromDetached :: (MonadFail m, Encapsulates struct) => b -> struct (Encap a) -> m (struct b)+fromDetached c = lens (fromEncap (return c) err)+ where err _ = fail "fromDetached: attached"++-- | Remove the content from the data structure to store it externally.+toDetached :: Encapsulates struct => struct a -> (a, struct (Encap a))+toDetached = let f a = (a, Detached) in lens f++-- | Transform the data structure into a content info, detaching the+-- encapsulated content. May be applied to structures with+-- 'EncapsulatedContent' or 'EncryptedContent'.+toDetachedCI :: Encapsulates struct => struct ByteString -> (ByteString, ContentInfo)+toDetachedCI = fmap toCI . toDetached
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/OriginatorInfo.hs view
@@ -0,0 +1,184 @@+-- |+-- Module : Crypto.Store.CMS.OriginatorInfo+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.OriginatorInfo+ ( OriginatorInfo(..)+ , CertificateChoice(..)+ , OtherCertificateFormat(..)+ , RevocationInfoChoice(..)+ , OtherRevocationInfoFormat(..)+ , originatorInfoASN1S+ , parseOriginatorInfo+ , hasChoiceOther+ ) where++import Control.Applicative++import Data.ASN1.Types+import Data.Maybe (fromMaybe)+import Data.Semigroup+import Data.X509++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Util++-- | Data types where choice "other" is available.+class HasChoiceOther a where+ -- | Return true when choice "other" is selected.+ hasChoiceOther :: a -> Bool++instance (HasChoiceOther a, Foldable f) => HasChoiceOther (f a) where+ hasChoiceOther = any hasChoiceOther++-- | Information about the originator of the content info, to be used when+-- a key management algorithm requires this information.+data OriginatorInfo = OriginatorInfo+ { originatorCerts :: [CertificateChoice]+ -- ^ The collection of certificates+ , originatorCRLs :: [RevocationInfoChoice]+ -- ^ The collection of CRLs+ }+ deriving (Show,Eq)++instance Semigroup OriginatorInfo where+ OriginatorInfo a b <> OriginatorInfo c d = OriginatorInfo (a <> c) (b <> d)++instance Monoid OriginatorInfo where+ mempty = OriginatorInfo [] []+ mappend = (<>)++instance HasChoiceOther OriginatorInfo where+ hasChoiceOther OriginatorInfo{..} =+ hasChoiceOther originatorCerts || hasChoiceOther originatorCRLs++instance ProduceASN1Object ASN1P OriginatorInfo where+ asn1s = originatorInfoASN1S Sequence++instance ParseASN1Object [ASN1Event] OriginatorInfo where+ parse = parseOriginatorInfo Sequence++-- | Generate ASN.1 with the specified constructed type for the originator+-- information.+originatorInfoASN1S :: ASN1ConstructionType -> OriginatorInfo -> ASN1PS+originatorInfoASN1S ty OriginatorInfo{..} =+ asn1Container ty $ gen 0 originatorCerts . gen 1 originatorCRLs+ where+ gen tag list+ | null list = id+ | otherwise = asn1Container (Container Context tag) (asn1s list)++-- | Parse originator information with the specified constructed type.+parseOriginatorInfo :: ASN1ConstructionType+ -> ParseASN1 [ASN1Event] OriginatorInfo+parseOriginatorInfo ty = onNextContainer ty $ do+ certs <- parseOptList 0+ crls <- parseOptList 1+ return OriginatorInfo { originatorCerts = certs+ , originatorCRLs = crls+ }+ where+ parseOptList tag =+ fromMaybe [] <$> onNextContainerMaybe (Container Context tag) parse++-- | Union type related to certificate formats.+data CertificateChoice+ = CertificateCertificate SignedCertificate -- ^ X.509 certificate+ | CertificateOther OtherCertificateFormat -- ^ Other format+ deriving (Show,Eq)++instance HasChoiceOther CertificateChoice where+ hasChoiceOther (CertificateOther _) = True+ hasChoiceOther _ = False++instance ProduceASN1Object ASN1P CertificateChoice where+ asn1s (CertificateCertificate cert) = asn1s cert+ asn1s (CertificateOther other) =+ otherCertificateFormatASN1PS (Container Context 3) other++instance ParseASN1Object [ASN1Event] CertificateChoice where+ parse = parseMain <|> parseOther+ where parseMain = CertificateCertificate <$> parse+ parseOther = CertificateOther <$>+ parseOtherCertificateFormat (Container Context 3)++-- | Union type related to revocation info formats.+data RevocationInfoChoice+ = RevocationInfoCRL SignedCRL+ -- ^ A CRL, ARL, Delta CRL, or an ACRL+ | RevocationInfoOther OtherRevocationInfoFormat+ -- ^ Other format+ deriving (Show,Eq)++instance HasChoiceOther RevocationInfoChoice where+ hasChoiceOther (RevocationInfoOther _) = True+ hasChoiceOther _ = False++instance ProduceASN1Object ASN1P RevocationInfoChoice where+ asn1s (RevocationInfoCRL crl) = asn1s crl+ asn1s (RevocationInfoOther other) =+ otherRevocationInfoFormatASN1PS (Container Context 1) other++instance ParseASN1Object [ASN1Event] RevocationInfoChoice where+ parse = parseMain <|> parseOther+ where parseMain = RevocationInfoCRL <$> parse+ parseOther = RevocationInfoOther <$>+ parseOtherRevocationInfoFormat (Container Context 1)++-- | Certificate information in a format not supported natively.+data OtherCertificateFormat = OtherCertificateFormat+ { otherCertFormat :: OID -- ^ Format identifier+ , otherCertValues :: [ASN1] -- ^ ASN.1 values using this format+ }+ deriving (Show,Eq)++otherCertificateFormatASN1PS :: ASN1Elem e+ => ASN1ConstructionType+ -> OtherCertificateFormat+ -> ASN1Stream e+otherCertificateFormatASN1PS ty OtherCertificateFormat{..} =+ asn1Container ty (f . v)+ where f = gOID otherCertFormat+ v = gMany otherCertValues++parseOtherCertificateFormat :: Monoid e+ => ASN1ConstructionType+ -> ParseASN1 e OtherCertificateFormat+parseOtherCertificateFormat ty = onNextContainer ty $ do+ OID f <- getNext+ v <- getMany getNext+ return OtherCertificateFormat { otherCertFormat = f+ , otherCertValues = v }++-- | Revocation information in a format not supported natively.+data OtherRevocationInfoFormat = OtherRevocationInfoFormat+ { otherRevInfoFormat :: OID -- ^ Format identifier+ , otherRevInfoValues :: [ASN1] -- ^ ASN.1 values using this format+ }+ deriving (Show,Eq)++otherRevocationInfoFormatASN1PS :: ASN1Elem e+ => ASN1ConstructionType+ -> OtherRevocationInfoFormat+ -> ASN1Stream e+otherRevocationInfoFormatASN1PS ty OtherRevocationInfoFormat{..} =+ asn1Container ty (f . v)+ where f = gOID otherRevInfoFormat+ v = gMany otherRevInfoValues++parseOtherRevocationInfoFormat :: Monoid e+ => ASN1ConstructionType+ -> ParseASN1 e OtherRevocationInfoFormat+parseOtherRevocationInfoFormat ty = onNextContainer ty $ do+ OID f <- getNext+ v <- getMany getNext+ return OtherRevocationInfoFormat { otherRevInfoFormat = f+ , otherRevInfoValues = v }
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/PEM.hs view
@@ -0,0 +1,77 @@+-- |+-- Module : Crypto.Store.CMS.PEM+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- PEM serialization and deserialization of CMS 'ContentInfo'.+module Crypto.Store.CMS.PEM+ ( readCMSFile+ , readCMSFileFromMemory+ , berToContentInfo+ , pemToContentInfo+ , writeCMSFile+ , writeCMSFileToMemory+ , contentInfoToDER+ , contentInfoToPEM+ ) where++import qualified Data.ByteString as B+import Data.Maybe (catMaybes)++import Crypto.Store.CMS.Info+import Crypto.Store.CMS.Util+import Crypto.Store.Error+import Crypto.Store.PEM+++-- Reading from PEM format++-- | Read content info elements from a PEM file.+readCMSFile :: FilePath -> IO [ContentInfo]+readCMSFile path = accumulate <$> readPEMs path++-- | Read content info elements from a bytearray in PEM format.+readCMSFileFromMemory :: B.ByteString -> [ContentInfo]+readCMSFileFromMemory = either (const []) accumulate . pemParseBS++accumulate :: [PEM] -> [ContentInfo]+accumulate = catMaybes . foldr (flip pemToContentInfo) []++-- | Read a content info from a bytearray in BER format.+berToContentInfo :: B.ByteString -> Either StoreError ContentInfo+berToContentInfo = decodeASN1Object++-- | Read a content info from a 'PEM' element and add it to the accumulator+-- list.+pemToContentInfo :: [Maybe ContentInfo] -> PEM -> [Maybe ContentInfo]+pemToContentInfo acc pem+ | pemName pem `elem` names = decode (pemContent pem)+ | otherwise = Nothing : acc+ where+ names = [ "CMS", "PKCS7" ]+ decode bs =+ case berToContentInfo bs of+ Left _ -> Nothing : acc+ Right info -> Just info : acc+++-- Writing to PEM format++-- | Write content info elements to a PEM file.+writeCMSFile :: FilePath -> [ContentInfo] -> IO ()+writeCMSFile path = B.writeFile path . writeCMSFileToMemory++-- | Write content info elements to a bytearray in PEM format.+writeCMSFileToMemory :: [ContentInfo] -> B.ByteString+writeCMSFileToMemory = pemsWriteBS . map contentInfoToPEM++-- | Generate a bytearray in DER format for a content info.+contentInfoToDER :: ContentInfo -> B.ByteString+contentInfoToDER = encodeASN1Object++-- | Generate PEM for a content info.+contentInfoToPEM :: ContentInfo -> PEM+contentInfoToPEM info = PEM { pemName = "CMS", pemHeader = [], pemContent = bs}+ where bs = contentInfoToDER info
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Signed.hs view
@@ -0,0 +1,337 @@+-- |+-- Module : Crypto.Store.CMS.Signed+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Crypto.Store.CMS.Signed+ ( EncapsulatedContent+ , SignedData(..)+ , SignerInfo(..)+ , SignerIdentifier(..)+ , IssuerAndSerialNumber(..)+ , ProducerOfSI+ , ConsumerOfSI+ , certSigner+ , withPublicKey+ , withSignerKey+ , withSignerCertificate+ , encapsulatedContentInfoASN1S+ , parseEncapsulatedContentInfo+ ) where++import Control.Applicative+import Control.Monad++import Data.ASN1.Types+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Hourglass+import Data.List+import Data.Maybe+import Data.X509++import Crypto.Random (MonadRandom)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.AuthEnveloped+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.OriginatorInfo+import Crypto.Store.CMS.Type+import Crypto.Store.CMS.Util+import Crypto.Store.Error++-- | Encapsulated content.+type EncapsulatedContent = ByteString++-- | Information related to a signer of a 'Crypto.Store.CMS.SignedData'. An+-- element contains the signature material that was produced.+data SignerInfo = SignerInfo+ { siSignerId :: SignerIdentifier+ -- ^ Identifier of the signer certificate+ , siDigestAlgorithm :: DigestAlgorithm+ -- ^ Digest algorithm used for the signature+ , siSignedAttrs :: [Attribute]+ -- ^ Optional signed attributes+ , siSignatureAlg :: SignatureAlg+ -- ^ Algorithm used for signature+ , siSignature :: SignatureValue+ -- ^ The signature value+ , siUnsignedAttrs :: [Attribute]+ -- ^ Optional unsigned attributes+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e SignerInfo where+ asn1s SignerInfo{..} =+ asn1Container Sequence (ver . sid . dig . sa . alg . sig . ua)+ where+ ver = gIntVal (getVersion siSignerId)+ sid = asn1s siSignerId+ dig = algorithmASN1S Sequence siDigestAlgorithm+ sa = attributesASN1S (Container Context 0) siSignedAttrs+ alg = algorithmASN1S Sequence siSignatureAlg+ sig = gOctetString siSignature+ ua = attributesASN1S (Container Context 1) siUnsignedAttrs++instance Monoid e => ParseASN1Object e SignerInfo where+ parse = onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v /= 1 && v /= 3) $+ throwParseError ("SignerInfo: parsed invalid version: " ++ show v)+ sid <- parse+ dig <- parseAlgorithm Sequence+ sAttrs <- parseAttributes (Container Context 0)+ alg <- parseAlgorithm Sequence+ OctetString sig <- getNext+ uAttrs <- parseAttributes (Container Context 1)+ return SignerInfo { siSignerId = sid+ , siDigestAlgorithm = dig+ , siSignedAttrs = sAttrs+ , siSignatureAlg = alg+ , siSignature = sig+ , siUnsignedAttrs = uAttrs+ }++getVersion :: SignerIdentifier -> Integer+getVersion (SignerIASN _) = 1+getVersion (SignerSKI _) = 3++-- | Return true when the signer info has version 3.+isVersion3 :: SignerInfo -> Bool+isVersion3 = (== 3) . getVersion . siSignerId++-- | Union type related to identification of the signer certificate.+data SignerIdentifier+ = SignerIASN IssuerAndSerialNumber -- ^ Issuer and Serial Number+ | SignerSKI ByteString -- ^ Subject Key Identifier+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e SignerIdentifier where+ asn1s (SignerIASN iasn) = asn1s iasn+ asn1s (SignerSKI ski) = asn1Container (Container Context 0)+ (gOctetString ski)++instance Monoid e => ParseASN1Object e SignerIdentifier where+ parse = parseIASN <|> parseSKI+ where parseIASN = SignerIASN <$> parse+ parseSKI = SignerSKI <$>+ onNextContainer (Container Context 0) parseOctetStringPrim++-- | Try to find a certificate with the specified identifier.+findSigner :: SignerIdentifier+ -> [SignedCertificate]+ -> Maybe (SignedCertificate, [SignedCertificate])+findSigner (SignerIASN iasn) certs =+ partitionHead (matchIASN . signedObject . getSigned) certs+ where+ matchIASN c =+ (iasnIssuer iasn, iasnSerial iasn) == (certIssuerDN c, certSerial c)+findSigner (SignerSKI ski) certs =+ partitionHead (matchSKI. signedObject . getSigned) certs+ where+ matchSKI c =+ case extensionGet (certExtensions c) of+ Just (ExtSubjectKeyId idBs) -> idBs == ski+ Nothing -> False++partitionHead :: (a -> Bool) -> [a] -> Maybe (a, [a])+partitionHead p l =+ case partition p l of+ (x : _, r) -> Just (x, r)+ ([] , _) -> Nothing++-- | Function able to produce a 'SignerInfo'.+type ProducerOfSI m = ContentType -> ByteString -> m (Either StoreError (SignerInfo, [CertificateChoice], [RevocationInfoChoice]))++-- | Function able to consume a 'SignerInfo'.+type ConsumerOfSI m = ContentType -> ByteString -> SignerInfo -> [CertificateChoice] -> [RevocationInfoChoice] -> m Bool++-- | Create a signer info with the specified signature algorithm and+-- credentials.+--+-- Two lists of optional attributes can be provided. The attributes will be+-- part of message signature when provided in the first list.+--+-- When the first list of attributes is provided, even empty list, signature is+-- computed from a digest of the content. When the list of attributes is+-- 'Nothing', no intermediate digest is used and the signature is computed from+-- the full message.+certSigner :: MonadRandom m+ => SignatureAlg+ -> PrivKey+ -> CertificateChain+ -> Maybe [Attribute]+ -> [Attribute]+ -> ProducerOfSI m+certSigner alg priv (CertificateChain chain) sAttrsM uAttrs ct msg =+ fmap build <$> generate+ where+ md = digest dig msg+ def = DigestAlgorithm Crypto.Store.CMS.Algorithms.SHA256+ cert = head chain+ obj = signedObject (getSigned cert)+ isn = IssuerAndSerialNumber (certIssuerDN obj) (certSerial obj)+ pub = certPubKey obj++ (dig, alg') = signatureResolveHash noAttr def alg++ noAttr = null sAttrs+ (sAttrs, input) =+ case sAttrsM of+ Nothing -> ([], msg)+ Just attrs ->+ let l = setContentTypeAttr ct $ setMessageDigestAttr md attrs+ in (l, encodeAuthAttrs l)++ generate = signatureGenerate alg' priv pub input+ build sig =+ let si = SignerInfo { siSignerId = SignerIASN isn+ , siDigestAlgorithm = dig+ , siSignedAttrs = sAttrs+ , siSignatureAlg = alg+ , siSignature = sig+ , siUnsignedAttrs = uAttrs+ }+ in (si, map CertificateCertificate chain, [])++-- | Verify that the signature was produced from the specified public key.+-- Ignores all certificates and CRLs contained in the signed data.+withPublicKey :: Applicative f => PubKey -> ConsumerOfSI f+withPublicKey pub ct msg SignerInfo{..} _ _ = pure $+ fromMaybe False $ do+ guard (noAttr || attrMatch)+ guard mdAccept+ alg <- signatureCheckHash siDigestAlgorithm siSignatureAlg+ return (signatureVerify alg pub input siSignature)+ where+ noAttr = null siSignedAttrs+ mdMatch = mdAttr == Just (digest siDigestAlgorithm msg)+ attrMatch = ctAttr == Just ct && mdMatch+ mdAttr = getMessageDigestAttr siSignedAttrs+ mdAccept = securityAcceptable siDigestAlgorithm+ ctAttr = getContentTypeAttr siSignedAttrs+ input = if noAttr then msg else encodeAuthAttrs siSignedAttrs++-- | Verify that the signature is valid with one of the X.509 certificates+-- contained in the signed data, but does not validate that the certificates are+-- valid. All transmitted certificates are implicitely trusted and all CRLs are+-- ignored.+withSignerKey :: Applicative f => ConsumerOfSI f+withSignerKey = withSignerCertificate (\_ _ -> pure True)++-- | Verify that the signature is valid with one of the X.509 certificates+-- contained in the signed data, and verify that the signer certificate is valid+-- using the validation function supplied. All CRLs are ignored.+withSignerCertificate :: Applicative f+ => (Maybe DateTime -> CertificateChain -> f Bool)+ -> ConsumerOfSI f+withSignerCertificate validate ct msg SignerInfo{..} certs crls =+ case getCertificateChain of+ Just chain -> validate mSigningTime chain+ Nothing -> pure False+ where+ getCertificateChain = do+ (cert, others) <- findSigner siSignerId x509Certificates+ let pub = certPubKey $ signedObject $ getSigned cert+ validSignature <- withPublicKey pub ct msg SignerInfo{..} certs crls+ guard validSignature+ return $ CertificateChain (cert : others)++ mSigningTime = getSigningTimeAttr siSignedAttrs++ x509Certificates = mapMaybe asX509 certs++ asX509 (CertificateCertificate c) = Just c+ asX509 _ = Nothing++-- | Signed content information.+data SignedData content = SignedData+ { sdDigestAlgorithms :: [DigestAlgorithm] -- ^ Digest algorithms+ , sdContentType :: ContentType -- ^ Inner content type+ , sdEncapsulatedContent :: content -- ^ Encapsulated content+ , sdCertificates :: [CertificateChoice] -- ^ The collection of certificates+ , sdCRLs :: [RevocationInfoChoice] -- ^ The collection of CRLs+ , sdSignerInfos :: [SignerInfo] -- ^ Per-signer information+ }+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P (SignedData (Encap EncapsulatedContent)) where+ asn1s SignedData{..} =+ asn1Container Sequence (ver . dig . ci . certs . crls . sis)+ where+ ver = gIntVal v+ dig = asn1Container Set (digestTypesASN1S sdDigestAlgorithms)+ ci = encapsulatedContentInfoASN1S sdContentType sdEncapsulatedContent+ certs = gen 0 sdCertificates+ crls = gen 1 sdCRLs+ sis = asn1Container Set (asn1s sdSignerInfos)++ gen tag list+ | null list = id+ | otherwise = asn1Container (Container Context tag) (asn1s list)++ v | hasChoiceOther sdCertificates = 5+ | hasChoiceOther sdCRLs = 5+ | any isVersion3 sdSignerInfos = 3+ | sdContentType == DataType = 1+ | otherwise = 3+++instance ParseASN1Object [ASN1Event] (SignedData (Encap EncapsulatedContent)) where+ parse =+ onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v > 5) $+ throwParseError ("SignedData: parsed invalid version: " ++ show v)+ dig <- onNextContainer Set parseDigestTypes+ (ct, bs) <- parseEncapsulatedContentInfo+ certs <- parseOptList 0+ crls <- parseOptList 1+ sis <- onNextContainer Set parse+ return SignedData { sdDigestAlgorithms = dig+ , sdContentType = ct+ , sdEncapsulatedContent = bs+ , sdCertificates = certs+ , sdCRLs = crls+ , sdSignerInfos = sis+ }+ where+ parseOptList tag =+ fromMaybe [] <$> onNextContainerMaybe (Container Context tag) parse++-- | Generate ASN.1 for EncapsulatedContentInfo.+encapsulatedContentInfoASN1S :: ASN1Elem e => ContentType -> Encap EncapsulatedContent -> ASN1Stream e+encapsulatedContentInfoASN1S ct ec = asn1Container Sequence (oid . cont)+ where oid = gOID (getObjectID ct)+ cont = encapsulatedASN1S (Container Context 0) ec++encapsulatedASN1S :: ASN1Elem e+ => ASN1ConstructionType -> Encap B.ByteString -> ASN1Stream e+encapsulatedASN1S _ Detached = id+encapsulatedASN1S ty (Attached bs) = asn1Container ty (gOctetString bs)++-- | Parse EncapsulatedContentInfo from ASN.1.+parseEncapsulatedContentInfo :: Monoid e => ParseASN1 e (ContentType, Encap EncapsulatedContent)+parseEncapsulatedContentInfo =+ onNextContainer Sequence $ do+ OID oid <- getNext+ withObjectID "content type" oid $ \ct ->+ wrap ct <$> onNextContainerMaybe (Container Context 0) parseOctetString+ where+ wrap ct Nothing = (ct, Detached)+ wrap ct (Just c) = (ct, Attached c)++digestTypesASN1S :: ASN1Elem e => [DigestAlgorithm] -> ASN1Stream e+digestTypesASN1S list cont = foldr (algorithmASN1S Sequence) cont list++parseDigestTypes :: Monoid e => ParseASN1 e [DigestAlgorithm]+parseDigestTypes = getMany (parseAlgorithm Sequence)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Type.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Crypto.Store.CMS.Type+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- CMS content information type.+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+module Crypto.Store.CMS.Type+ ( ContentType(..)+ , Encap(..)+ , fromEncap+ ) where++import Data.ASN1.OID++import Crypto.Store.CMS.Util++-- | CMS content information type.+data ContentType = DataType -- ^ Arbitrary octet string+ | SignedDataType -- ^ Signed content info+ | EnvelopedDataType -- ^ Enveloped content info+ | DigestedDataType -- ^ Content info with associated digest+ | EncryptedDataType -- ^ Encrypted content info+ | AuthenticatedDataType -- ^ Authenticated content info+ | AuthEnvelopedDataType -- ^ Authenticated-enveloped content info+ deriving (Show,Eq)++instance Enumerable ContentType where+ values = [ DataType+ , SignedDataType+ , EnvelopedDataType+ , DigestedDataType+ , EncryptedDataType+ , AuthenticatedDataType+ , AuthEnvelopedDataType+ ]++instance OIDable ContentType where+ getObjectID DataType = [1,2,840,113549,1,7,1]+ getObjectID SignedDataType = [1,2,840,113549,1,7,2]+ getObjectID EnvelopedDataType = [1,2,840,113549,1,7,3]+ getObjectID DigestedDataType = [1,2,840,113549,1,7,5]+ getObjectID EncryptedDataType = [1,2,840,113549,1,7,6]+ getObjectID AuthenticatedDataType = [1,2,840,113549,1,9,16,1,2]+ getObjectID AuthEnvelopedDataType = [1,2,840,113549,1,9,16,1,23]++instance OIDNameable ContentType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Denote the state of encapsulated content in a CMS data structure. This+-- type is isomorphic to 'Maybe'.+data Encap a+ = Detached -- ^ Content is stored externally to the structure+ | Attached a -- ^ Content is stored inside the CMS struture+ deriving (Show,Eq)++instance Functor Encap where+ fmap _ Detached = Detached+ fmap f (Attached c) = Attached (f c)++instance Applicative Encap where+ pure = Attached++ Attached f <*> e = fmap f e+ Detached <*> _ = Detached++instance Foldable Encap where+ foldMap = fromEncap mempty++ foldr _ d Detached = d+ foldr f d (Attached c) = f c d++ foldl _ d Detached = d+ foldl f d (Attached c) = f d c++instance Traversable Encap where+ traverse _ Detached = pure Detached+ traverse f (Attached c) = Attached <$> f c++-- | Fold over an 'Encap' value. This is similar to function 'maybe'. If the+-- content is detached, the first argument is returned. Otherwise the second+-- argument is applied to the content.+fromEncap :: b -> (a -> b) -> Encap a -> b+fromEncap d _ Detached = d+fromEncap _ f (Attached c) = f c
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/CMS/Util.hs view
@@ -0,0 +1,259 @@+-- |+-- Module : Crypto.Store.CMS.Util+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- CMS and ASN.1 utilities+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Crypto.Store.CMS.Util+ (+ -- * Testing ASN.1 types+ nullOrNothing+ , intOrNothing+ , dateTimeOrNothing+ -- * Object Identifiers+ , OIDTable+ , lookupOID+ , Enumerable(..)+ , OIDNameableWrapper(..)+ , withObjectID+ -- * Parsing octet strings+ , parseOctetString+ , parseOctetStringPrim+ , parseOctetStrings+ -- * Parsing and encoding ASN.1 objects+ , ASN1Event+ , ASN1ObjectExact(..)+ , ProduceASN1Object(..)+ , encodeASN1Object+ , ParseASN1Object(..)+ , decodeASN1Object+ -- * Algorithm Identifiers+ , AlgorithmId(..)+ , algorithmASN1S+ , algorithmMaybeASN1S+ , parseAlgorithm+ , parseAlgorithmMaybe+ -- * Miscellaneous functions+ , orElse+ ) where++import Control.Applicative++import Data.ASN1.BinaryEncoding+import Data.ASN1.BinaryEncoding.Raw+import Data.ASN1.Encoding+import Data.ASN1.OID+import Data.ASN1.Types+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.List (find)+import Data.X509++import Time.Types (DateTime)++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.Error++-- | Try to parse a 'Null' ASN.1 value.+nullOrNothing :: ASN1 -> Maybe ()+nullOrNothing Null = Just ()+nullOrNothing _ = Nothing++-- | Try to parse an 'IntVal' ASN.1 value.+intOrNothing :: ASN1 -> Maybe Integer+intOrNothing (IntVal i) = Just i+intOrNothing _ = Nothing++-- | Try to parse a 'DateTime' ASN.1 value.+dateTimeOrNothing :: ASN1 -> Maybe DateTime+dateTimeOrNothing (ASN1Time _ t _) = Just t+dateTimeOrNothing _ = Nothing++-- | Mapping between values and OIDs.+type OIDTable a = [(a, OID)]++-- | Find the value associated to an OID.+lookupByOID :: OIDTable a -> OID -> Maybe a+lookupByOID table oid = fst <$> find ((==) oid . snd) table++-- | Find the OID associated to a value.+lookupOID :: Eq a => OIDTable a -> a -> Maybe OID+lookupOID table a = lookup a table++-- | Types with a finite set of values.+class Enumerable a where+ -- | Return all possible values for the given type.+ values :: [a]++-- | Type used to transform a 'Enumerable' instance to an 'OIDNameable'+-- instance.+newtype OIDNameableWrapper a = OIDNW { unOIDNW :: a }+ deriving (Show,Eq)++instance (Enumerable a, OIDable a) => OIDNameable (OIDNameableWrapper a) where+ fromObjectID = lookupByOID table+ where table = [ (OIDNW val, getObjectID val) | val <- values ]++-- | Convert the specified OID and apply a parser to the result.+withObjectID :: OIDNameable a+ => String -> OID -> (a -> ParseASN1 e b) -> ParseASN1 e b+withObjectID name oid fn =+ case fromObjectID oid of+ Just val -> fn val+ Nothing ->+ throwParseError ("Unsupported " ++ name ++ ": OID " ++ show oid)++-- | Objects that can produce an ASN.1 stream.+class ProduceASN1Object e obj where+ asn1s :: obj -> ASN1Stream e++instance ProduceASN1Object e obj => ProduceASN1Object e [obj] where+ asn1s l r = foldr asn1s r l++instance ASN1Elem e => ProduceASN1Object e DistinguishedName where+ asn1s = asn1Container Sequence . inner+ where+ inner (DistinguishedName dn) cont = foldr dnSet cont dn+ dnSet (oid, cs) =+ asn1Container Set $+ asn1Container Sequence (gOID oid . gASN1String cs)++instance (Show a, Eq a, ASN1Object a) => ProduceASN1Object ASN1P (SignedExact a) where+ asn1s = gEncoded . encodeSignedObject++-- | Encode the ASN.1 object to DER format.+encodeASN1Object :: ProduceASN1Object ASN1P obj => obj -> ByteString+encodeASN1Object = encodeASN1S . asn1s++-- | Objects that can be parsed from an ASN.1 stream.+class Monoid e => ParseASN1Object e obj where+ parse :: ParseASN1 e obj++instance ParseASN1Object e obj => ParseASN1Object e [obj] where+ parse = getMany parse++instance Monoid e => ParseASN1Object e DistinguishedName where+ parse = DistinguishedName <$> onNextContainer Sequence inner+ where+ inner = concat <$> getMany parseOne+ parseOne =+ onNextContainer Set $ getMany $+ onNextContainer Sequence $ do+ OID oid <- getNext+ ASN1String cs <- getNext+ return (oid, cs)++instance (Show a, Eq a, ASN1Object a) => ParseASN1Object [ASN1Event] (SignedExact a) where+ parse = withAnnotations parseSequence >>= finish+ where+ parseSequence = onNextContainer Sequence (getMany getNext)+ finish (_, events) =+ case decodeSignedObject (toByteString events) of+ Right se -> return se+ Left err -> throwParseError ("SignedExact: " ++ err)++-- | Create an ASN.1 object from a bytearray in BER format.+decodeASN1Object :: ParseASN1Object [ASN1Event] obj => ByteString -> Either StoreError obj+decodeASN1Object bs =+ case decodeASN1Repr' BER bs of+ Left e -> Left (DecodingError e)+ Right asn1 ->+ case runParseASN1State_ parse asn1 of+ Right (obj, []) -> Right obj+ Right _ -> Left (ParseFailure "Incomplete parse")+ Left e -> Left (ParseFailure e)++-- | An ASN.1 object associated with the raw data it was parsed from.+data ASN1ObjectExact a = ASN1ObjectExact+ { exactObject :: a -- ^ The wrapped ASN.1 object+ , exactObjectRaw :: ByteString -- ^ The raw representation of this object+ } deriving Show++instance Eq a => Eq (ASN1ObjectExact a)+ where a == b = exactObject a == exactObject b++instance ProduceASN1Object ASN1P a => ProduceASN1Object ASN1P (ASN1ObjectExact a) where+ asn1s = gEncoded . exactObjectRaw++instance ParseASN1Object [ASN1Event] a => ParseASN1Object [ASN1Event] (ASN1ObjectExact a) where+ parse = do+ (obj, events) <- withAnnotations parse+ let objRaw = toByteString events+ return ASN1ObjectExact { exactObject = obj, exactObjectRaw = objRaw }++-- | Algorithm identifier with associated parameter.+class AlgorithmId param where+ type AlgorithmType param+ algorithmName :: param -> String+ algorithmType :: param -> AlgorithmType param+ parameterASN1S :: ASN1Elem e => param -> ASN1Stream e+ parseParameter :: Monoid e => AlgorithmType param -> ParseASN1 e param++-- | Transform the algorithm identifier to ASN.1 stream.+algorithmASN1S :: (ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param))+ => ASN1ConstructionType -> param -> ASN1Stream e+algorithmASN1S ty p = asn1Container ty (oid . parameterASN1S p)+ where typ = algorithmType p+ oid = gOID (getObjectID typ)++-- | Transform the optional algorithm identifier to ASN.1 stream.+algorithmMaybeASN1S :: (ASN1Elem e, AlgorithmId param, OIDable (AlgorithmType param))+ => ASN1ConstructionType -> Maybe param -> ASN1Stream e+algorithmMaybeASN1S _ Nothing = id+algorithmMaybeASN1S ty (Just p) = algorithmASN1S ty p++-- | Parse an algorithm identifier from an ASN.1 stream.+parseAlgorithm :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))+ => ASN1ConstructionType -> ParseASN1 e param+parseAlgorithm ty = onNextContainer ty $ do+ OID oid <- getNext+ withObjectID (getName undefined) oid parseParameter+ where+ getName :: param -> String+ getName = algorithmName++-- | Parse an optional algorithm identifier from an ASN.1 stream.+parseAlgorithmMaybe :: forall e param . (Monoid e, AlgorithmId param, OIDNameable (AlgorithmType param))+ => ASN1ConstructionType -> ParseASN1 e (Maybe param)+parseAlgorithmMaybe ty = onNextContainerMaybe ty $ do+ OID oid <- getNext+ withObjectID (getName undefined) oid parseParameter+ where+ getName :: param -> String+ getName = algorithmName++-- | Execute the second action only if the first action produced 'Nothing'.+orElse :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+orElse pa pb = do+ va <- pa+ case va of+ Nothing -> pb+ _ -> return va++-- | Parse an octet string, in primitive or constructed encodings.+parseOctetString :: Monoid e => ParseASN1 e ByteString+parseOctetString = parseOctetStringPrim <|> parseConstructed+ where+ parseConstructed = onNextContainer (Container Universal 4) parseOctetStrings++-- | Parse an octet string in primitive encoding.+parseOctetStringPrim :: Monoid e => ParseASN1 e ByteString+parseOctetStringPrim = do+ next <- getNext+ case next of+ OctetString bs -> return bs+ _ -> throwParseError "parseOctetStringPrim: parsed unexpected content"++-- | Parse some octet strings, in primitive or constructed encodings, and+-- concatenate the result.+parseOctetStrings :: Monoid e => ParseASN1 e ByteString+parseOctetStrings = B.concat <$> getMany parseOctetString
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/Cipher/RC2.hs view
@@ -0,0 +1,53 @@+-- |+-- Module : Crypto.Store.Cipher.RC2+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : stable+-- Portability : good+--+-- Implementation of RC2 block cipher, a legacy algorithm providing weak+-- security. Use only for compatibility with software requiring this cipher and+-- data which is not sensitive.+module Crypto.Store.Cipher.RC2+ ( RC2+ , rc2WithEffectiveKeyLength+ ) where++import Data.ByteArray (ByteArrayAccess)+import qualified Data.ByteArray as B+import Data.Maybe (fromMaybe)++import Crypto.Error+import Crypto.Cipher.Types++import Crypto.Store.Cipher.RC2.Primitive+import Crypto.Store.Util++-- | RC2 block cipher. Key is between 8 and 1024 bits.+newtype RC2 = RC2 Key++instance Cipher RC2 where+ cipherName _ = "RC2"+ cipherKeySize _ = KeySizeRange 1 128+ cipherInit = fmap RC2 . initRC2 Nothing++instance BlockCipher RC2 where+ blockSize _ = 8+ ecbEncrypt (RC2 k) = mapAsWord64LE (encrypt k)+ ecbDecrypt (RC2 k) = mapAsWord64LE (decrypt k)++-- | Build a RC2 cipher with the specified effective key length (in bits).+rc2WithEffectiveKeyLength :: ByteArrayAccess key+ => Int -> key -> CryptoFailable RC2+rc2WithEffectiveKeyLength bits key+ | bits < 1 = CryptoFailed CryptoError_KeySizeInvalid+ | bits > 1024 = CryptoFailed CryptoError_KeySizeInvalid+ | otherwise = RC2 <$> initRC2 (Just bits) key++initRC2 :: ByteArrayAccess key => Maybe Int -> key -> CryptoFailable Key+initRC2 mbits bs+ | len < 1 = CryptoFailed CryptoError_KeySizeInvalid+ | len <= 128 = CryptoPassed (buildKey t1 bs)+ | otherwise = CryptoFailed CryptoError_KeySizeInvalid+ where len = B.length bs+ t1 = fromMaybe (8 * len) mbits
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/Cipher/RC2/Primitive.hs view
@@ -0,0 +1,236 @@+-- |+-- Module : Crypto.Store.Cipher.RC2.Primitive+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : stable+-- Portability : good+--+{-# LANGUAGE Rank2Types #-}+module Crypto.Store.Cipher.RC2.Primitive+ ( Key+ , buildKey+ , encrypt+ , decrypt+ ) where++import Basement.Block+import Basement.Compat.IsList+import Basement.Endianness+import Basement.Types.OffsetSize++import Control.Monad (forM_)++import Data.Bits+import Data.ByteArray (ByteArrayAccess)+import qualified Data.ByteArray as B+import Data.Word++import Foreign.Storable+++-- | Expanded RC2 key+newtype Key = Key (Block Word16) -- [ K[0], K[1], ..., K[63] ]++data Q = Q {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16+ {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16+++-- Utilities++decomp64 :: Word64 -> Q+decomp64 x =+ let d = fromIntegral (x `shiftR` 48)+ c = fromIntegral (x `shiftR` 32)+ b = fromIntegral (x `shiftR` 16)+ a = fromIntegral x+ in Q a b c d++comp64 :: Q -> Word64+comp64 (Q a b c d) =+ (fromIntegral d `shiftL` 48) .|.+ (fromIntegral c `shiftL` 32) .|.+ (fromIntegral b `shiftL` 16) .|.+ fromIntegral a++getR :: Q -> Word8 -> Word16+getR (Q a b c d) i =+ case i .&. 3 of+ 0 -> a+ 1 -> b+ 2 -> c+ _ -> d+{-# INLINE getR #-}++setR :: Q -> Word8 -> Word16 -> Q+setR (Q a b c d) i x =+ case i .&. 3 of+ 0 -> Q x b c d+ 1 -> Q a x c d+ 2 -> Q a b x d+ _ -> Q a b c x+{-# INLINE setR #-}++rol :: Word8 -> Word16 -> Word16+rol i =+ case i .&. 3 of+ 0 -> flip rotateL 1+ 1 -> flip rotateL 2+ 2 -> flip rotateL 3+ _ -> flip rotateL 5+{-# INLINE rol #-}++ror :: Word8 -> Word16 -> Word16+ror i =+ case i .&. 3 of+ 0 -> flip rotateR 1+ 1 -> flip rotateR 2+ 2 -> flip rotateR 3+ _ -> flip rotateR 5+{-# INLINE ror #-}++f5 :: (a -> a) -> a -> a+f5 f = f . f . f . f . f++f6 :: (a -> a) -> a -> a+f6 f = f . f . f . f . f . f+++-- Encryption++-- | Encrypts a block using the specified key+encrypt :: Key -> Word64 -> Word64+encrypt k = comp64 . enc k . decomp64++enc :: Key -> Q -> Q+enc k r =+ fst $ f5 (mixingRound k) $ mashingRound k+ $ f6 (mixingRound k) $ mashingRound k+ $ f5 (mixingRound k) (r, 0)++-- Decryption++-- | Decrypts a block using the specified key+decrypt :: Key -> Word64 -> Word64+decrypt k = comp64 . dec k . decomp64++dec :: Key -> Q -> Q+dec k r =+ fst $ f5 (rmixingRound k) $ rmashingRound k+ $ f6 (rmixingRound k) $ rmashingRound k+ $ f5 (rmixingRound k) (r, 63)+++-- Encryptiong rounds++mixUp :: Key -> Word8 -> (Q, Int) -> (Q, Int)+mixUp k i input@(r, j) = seq r' $ seq j' (r', j')+ where j' = j + 1+ r' = setR r i (rol i (ri + gmix k i input))+ ri = getR r i+{-# INLINE mixUp #-}++mixingRound :: Key -> (Q, Int) -> (Q, Int)+mixingRound k = mixUp k 3 . mixUp k 2 . mixUp k 1 . mixUp k 0++mash :: Key -> Word8 -> (Q, Int) -> (Q, Int)+mash = gmash (+)+{-# INLINE mash #-}++mashingRound :: Key -> (Q, Int) -> (Q, Int)+mashingRound k = mash k 3 . mash k 2 . mash k 1 . mash k 0+++-- Decryption rounds++rmixUp :: Key -> Word8 -> (Q, Int) -> (Q, Int)+rmixUp k i input@(r, j) = seq r' $ seq j' (r', j')+ where j' = j - 1+ r' = setR r i (ri - gmix k i input)+ ri = ror i (getR r i)+{-# INLINE rmixUp #-}++rmixingRound :: Key -> (Q, Int) -> (Q, Int)+rmixingRound k = rmixUp k 0 . rmixUp k 1 . rmixUp k 2 . rmixUp k 3++rmash :: Key -> Word8 -> (Q, Int) -> (Q, Int)+rmash = gmash (-)+{-# INLINE rmash #-}++rmashingRound :: Key -> (Q, Int) -> (Q, Int)+rmashingRound k = rmash k 0 . rmash k 1 . rmash k 2 . rmash k 3+++-- Generic rounds++gmix :: Key -> Word8 -> (Q, Int) -> Word16+gmix (Key k) i (r, j) = kj + (ri1 .&. ri2) + (complement ri1 .&. ri3)+ where ri1 = getR r (i - 1)+ ri2 = getR r (i - 2)+ ri3 = getR r (i - 3)+ kj = unsafeIndex k (Offset j)+{-# INLINE gmix #-}++gmash :: (Word16 -> Word16 -> Word16)+ -> Key -> Word8 -> (Q, Int) -> (Q, Int)+gmash op (Key k) i (r, j) = seq r' $ seq j (r', j)+ where r' = setR r i (ri `op` kp)+ ri = getR r i+ ri1 = getR r (i - 1)+ kp = unsafeIndex k $ Offset (fromIntegral ri1 .&. 63)+{-# INLINE gmash #-}+++-- Key expansion++-- | Perform key expansion+buildKey :: ByteArrayAccess key+ => Int -- ^ Effective key length in bits+ -> key -- ^ Input key between 1 and 128 bytes+ -> Key -- ^ Expanded key+buildKey t1 key = Key $ doCast $ B.allocAndFreeze 128 $ \p -> do+ B.copyByteArrayToPtr key p++ forM_ [t .. 127] $ \i -> do+ pos <- (+) <$> peekElemOff p (i - 1) <*> peekElemOff p (i - t)+ let b = unsafeIndex piTable (fromIntegral pos)+ pokeElemOff p i b++ pos' <- (.&. tm) <$> peekElemOff p (128 - t8)+ let b' = unsafeIndex piTable (fromIntegral pos')+ pokeElemOff p (128 - t8) b'++ forM_ (Prelude.reverse [0 .. 127 - t8]) $ \i -> do+ pos <- xor <$> peekElemOff p (i + 1) <*> peekElemOff p (i + t8)+ let b = unsafeIndex piTable (fromIntegral pos)+ pokeElemOff p i b++ where t = B.length key+ t8 = (t1 + 7) `div` 8+ tm | t1 == 8 * t8 = 255+ | otherwise = 255 `mod` shiftL 1 (8 + t1 - 8 * t8)++ doCast :: Block Word8 -> Block Word16+ doCast = Basement.Block.map fromLE . cast+++-- PITABLE++piTable :: Block Word8+piTable = fromList+ [ 0xd9, 0x78, 0xf9, 0xc4, 0x19, 0xdd, 0xb5, 0xed, 0x28, 0xe9, 0xfd, 0x79, 0x4a, 0xa0, 0xd8, 0x9d+ , 0xc6, 0x7e, 0x37, 0x83, 0x2b, 0x76, 0x53, 0x8e, 0x62, 0x4c, 0x64, 0x88, 0x44, 0x8b, 0xfb, 0xa2+ , 0x17, 0x9a, 0x59, 0xf5, 0x87, 0xb3, 0x4f, 0x13, 0x61, 0x45, 0x6d, 0x8d, 0x09, 0x81, 0x7d, 0x32+ , 0xbd, 0x8f, 0x40, 0xeb, 0x86, 0xb7, 0x7b, 0x0b, 0xf0, 0x95, 0x21, 0x22, 0x5c, 0x6b, 0x4e, 0x82+ , 0x54, 0xd6, 0x65, 0x93, 0xce, 0x60, 0xb2, 0x1c, 0x73, 0x56, 0xc0, 0x14, 0xa7, 0x8c, 0xf1, 0xdc+ , 0x12, 0x75, 0xca, 0x1f, 0x3b, 0xbe, 0xe4, 0xd1, 0x42, 0x3d, 0xd4, 0x30, 0xa3, 0x3c, 0xb6, 0x26+ , 0x6f, 0xbf, 0x0e, 0xda, 0x46, 0x69, 0x07, 0x57, 0x27, 0xf2, 0x1d, 0x9b, 0xbc, 0x94, 0x43, 0x03+ , 0xf8, 0x11, 0xc7, 0xf6, 0x90, 0xef, 0x3e, 0xe7, 0x06, 0xc3, 0xd5, 0x2f, 0xc8, 0x66, 0x1e, 0xd7+ , 0x08, 0xe8, 0xea, 0xde, 0x80, 0x52, 0xee, 0xf7, 0x84, 0xaa, 0x72, 0xac, 0x35, 0x4d, 0x6a, 0x2a+ , 0x96, 0x1a, 0xd2, 0x71, 0x5a, 0x15, 0x49, 0x74, 0x4b, 0x9f, 0xd0, 0x5e, 0x04, 0x18, 0xa4, 0xec+ , 0xc2, 0xe0, 0x41, 0x6e, 0x0f, 0x51, 0xcb, 0xcc, 0x24, 0x91, 0xaf, 0x50, 0xa1, 0xf4, 0x70, 0x39+ , 0x99, 0x7c, 0x3a, 0x85, 0x23, 0xb8, 0xb4, 0x7a, 0xfc, 0x02, 0x36, 0x5b, 0x25, 0x55, 0x97, 0x31+ , 0x2d, 0x5d, 0xfa, 0x98, 0xe3, 0x8a, 0x92, 0xae, 0x05, 0xdf, 0x29, 0x10, 0x67, 0x6c, 0xba, 0xc9+ , 0xd3, 0x00, 0xe6, 0xcf, 0xe1, 0x9e, 0xa8, 0x2c, 0x63, 0x16, 0x01, 0x3f, 0x58, 0xe2, 0x89, 0xa9+ , 0x0d, 0x38, 0x34, 0x1b, 0xab, 0x33, 0xff, 0xb0, 0xbb, 0x48, 0x0c, 0x5f, 0xb9, 0xb1, 0xcd, 0x2e+ , 0xc5, 0xf3, 0xdb, 0x47, 0xe5, 0xa5, 0x9c, 0x77, 0x0a, 0xa6, 0x20, 0x68, 0xfe, 0x7f, 0xc1, 0xad+ ]
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/Error.hs view
@@ -0,0 +1,69 @@+-- |+-- Module : Crypto.Store.Error+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Error data type.+module Crypto.Store.Error+ ( StoreError(..)+ , fromCryptoFailable+ ) where++import Crypto.Error+import Crypto.PubKey.RSA.Types as RSA++import Data.ASN1.Error++-- | Error type in cryptostore.+data StoreError =+ CryptoError CryptoError+ -- ^ Wraps a cryptonite error+ | RSAError RSA.Error+ -- ^ Wraps an RSA crypto error+ | DecodingError ASN1Error+ -- ^ Error while decoding ASN.1 content+ | ParseFailure String+ -- ^ Error while parsing an ASN.1 object+ | DecryptionFailed+ -- ^ Unable to decrypt, incorrect key or password?+ | BadContentMAC+ -- ^ MAC verification failed, incorrect key or password?+ | BadChecksum+ -- ^ Checksum verification failed, incorrect key or password?+ | DigestMismatch+ -- ^ Digest verification failed+ | SignatureNotVerified+ -- ^ Signature verification failed+ | InvalidInput String+ -- ^ Some condition is not met about input to algorithm+ | InvalidPassword String+ -- ^ Some condition is not met about input password+ | InvalidParameter String+ -- ^ Some condition is not met about algorithm parameters+ | UnexpectedPublicKeyType+ -- ^ The algorithm expects another public key type+ | UnexpectedPrivateKeyType+ -- ^ The algorithm expects another private key type+ | RecipientTypeMismatch+ -- ^ Returned when the type of recipient info does not match the consumer+ -- function+ | RecipientKeyNotFound+ -- ^ The certificate provided does not match any encrypted key found+ | NoRecipientInfoFound+ -- ^ No recipient info is available in the enveloped data+ | NoRecipientInfoMatched+ -- ^ No recipient info could be used with the consumer function+ | UnsupportedOriginatorFormat+ -- ^ Only anonymous public key is supported+ | UnsupportedEllipticCurve+ -- ^ The elliptic curve used is not supported+ | NamedCurveRequired+ -- ^ The algorithm requires a named elliptic curve+ deriving (Show,Eq)++-- | Turn a 'CryptoFailed' into a 'StoreError'.+fromCryptoFailable ::CryptoFailable a -> Either StoreError a+fromCryptoFailable (CryptoPassed a) = Right a+fromCryptoFailable (CryptoFailed e) = Left (CryptoError e)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/AES.hs view
@@ -0,0 +1,145 @@+-- |+-- Module : Crypto.Store.KeyWrap.AES+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- AES Key Wrap (<https://tools.ietf.org/html/rfc3394 RFC 3394>) and Extended+-- Key Wrap (<https://tools.ietf.org/html/rfc5649 RFC 5649>)+--+-- Should be used with a cipher from module "Crypto.Cipher.AES".+{-# LANGUAGE BangPatterns #-}+module Crypto.Store.KeyWrap.AES+ ( wrap+ , unwrap+ , wrapPad+ , unwrapPad+ ) where++import Data.Bits+import Data.ByteArray (ByteArray, ByteArrayAccess, Bytes)+import qualified Data.ByteArray as B+import Data.List+import Data.Word++import Crypto.Cipher.Types++import Foreign.Storable++import Crypto.Store.Error+import Crypto.Store.Util++type Chunked ba = [ba]+type Pair ba = (ba, ba)++-- TODO: should use a low-level AES implementation to reduce allocations++aes' :: (BlockCipher aes, ByteArray ba) => aes -> Pair ba -> ba+aes' cipher (msb, lsb) = ecbEncrypt cipher (B.append msb lsb)++aes :: (BlockCipher aes, ByteArray ba) => aes -> Pair ba -> Pair ba+aes cipher = B.splitAt 8 . aes' cipher++aesrev' :: (BlockCipher aes, ByteArray ba) => aes -> ba -> Pair ba+aesrev' cipher = B.splitAt 8 . ecbDecrypt cipher++aesrev :: (BlockCipher aes, ByteArray ba) => aes -> Pair ba -> Pair ba+aesrev cipher (msb, lsb) = aesrev' cipher (B.append msb lsb)++wrapc :: (BlockCipher aes, ByteArray ba)+ => aes -> ba -> Chunked ba -> Chunked ba+wrapc cipher iiv list = uncurry (:) $ foldl' pass (iiv, list) [0 .. 5]+ where+ !n = fromIntegral (length list)+ pass (a, l) j = go a (n * j + 1) l+ go a !_ [] = (a, [])+ go a !i (r : rs) =+ let (a', t) = aes cipher (a, r)+ in (t :) <$> go (xorWith a' i) (succ i) rs++unwrapc :: (BlockCipher aes, ByteArray ba)+ => aes -> Chunked ba -> Either StoreError (ba, Chunked ba)+unwrapc _ [] = Left (InvalidInput "KeyWrap.AES: input too short")+unwrapc cipher (iv:list) = Right (iiv, reverse out)+ where+ (iiv, out) = foldl' pass (iv, reverse list) (reverse [0 .. 5])+ !n = fromIntegral (length list)+ pass (a, l) j = go a (n * j + n) l+ go a !_ [] = (a, [])+ go a !i (r : rs) =+ let (a', t) = aesrev cipher (xorWith a i, r)+ in (t :) <$> go a' (pred i) rs++-- | Wrap a key with the specified AES cipher.+wrap :: (BlockCipher aes, ByteArray ba) => aes -> ba -> Either StoreError ba+wrap cipher bs = unchunks . wrapc cipher iiv <$> chunks bs+ where iiv = B.replicate 8 0xA6++-- | Unwrap an encrypted key with the specified AES cipher.+unwrap :: (BlockCipher aes, ByteArray ba) => aes -> ba -> Either StoreError ba+unwrap cipher bs = unchunks <$> (check =<< unwrapc cipher =<< chunks bs)+ where+ check (iiv, out)+ | constAllEq 0xA6 iiv = Right out+ | otherwise = Left BadChecksum++chunks :: ByteArray ba => ba -> Either StoreError (Chunked ba)+chunks bs | B.null bs = Right []+ | B.length bs < 8 = Left (InvalidInput "KeyWrap.AES: input is not multiple of 8 bytes")+ | otherwise = let (a, b) = B.splitAt 8 bs in (a :) <$> chunks b++unchunks :: ByteArray ba => Chunked ba -> ba+unchunks = B.concat++padMask :: Bytes+padMask = B.pack [0xA6, 0x59, 0x59, 0xA6, 0x00, 0x00, 0x00, 0x00]++pad :: ByteArray ba => Int -> ba -> Either StoreError (Pair ba)+pad inlen bs | inlen == 0 = Left (InvalidInput "KeyWrap.AES: input is empty")+ | padlen == 8 = Right (aiv, bs)+ | otherwise = Right (aiv, bs `B.append` B.zero padlen)+ where padlen = 8 - mod inlen 8+ aiv = xorWith padMask (fromIntegral inlen)++unpad :: ByteArray ba => Int -> Pair ba -> Either StoreError ba+unpad inlen (aiv, b)+ | badlen = Left BadChecksum+ | constAllEq 0 p = Right bs+ | otherwise = Left BadChecksum+ where aivlen = fromIntegral (unxor padMask aiv)+ badlen = inlen < aivlen + 8 || inlen >= aivlen + 16+ (bs, p) = B.splitAt aivlen b++-- | Pad and wrap a key with the specified AES cipher.+wrapPad :: (BlockCipher aes, ByteArray ba) => aes -> ba -> Either StoreError ba+wrapPad cipher bs = doWrap =<< pad inlen bs+ where+ inlen = B.length bs+ doWrap (aiv, b)+ | inlen <= 8 = Right $ aes' cipher (aiv, b)+ | otherwise = unchunks . wrapc cipher aiv <$> chunks b++-- | Unwrap and unpad an encrypted key with the specified AES cipher.+unwrapPad :: (BlockCipher aes, ByteArray ba) => aes -> ba -> Either StoreError ba+unwrapPad cipher bs = unpad inlen =<< doUnwrap+ where+ inlen = B.length bs+ doUnwrap+ | inlen == 16 = let (aiv, b) = aesrev' cipher bs in Right (aiv, b)+ | otherwise = fmap unchunks <$> (unwrapc cipher =<< chunks bs)++xorWith :: (ByteArrayAccess bin, ByteArray bout) => bin -> Word64 -> bout+xorWith bs !i = B.copyAndFreeze bs $ \dst -> loop dst len i+ where !len = B.length bs+ loop _ 0 !_ = return ()+ loop _ _ 0 = return () -- return early (constant-time not needed)+ loop p n j = do+ b <- peekByteOff p (n - 1)+ let mask = fromIntegral j :: Word8+ pokeByteOff p (n - 1) (xor b mask)+ loop p (n - 1) (shiftR j 8)++unxor :: (ByteArrayAccess bx, ByteArrayAccess by) => bx -> by -> Word64+unxor x y = foldl' f 0 $ zipWith xor (B.unpack x) (B.unpack y)+ where f acc z = shiftL acc 8 + fromIntegral z
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/RC2.hs view
@@ -0,0 +1,91 @@+-- |+-- Module : Crypto.Store.KeyWrap.RC2+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- RC2 Key Wrap (<https://tools.ietf.org/html/rfc3217 RFC 3217>)+--+-- Should be used with a cipher from module "Crypto.Store.Cipher.RC2".+module Crypto.Store.KeyWrap.RC2+ ( wrap+ , wrap'+ , unwrap+ ) where++import Data.ByteArray (ByteArray)+import qualified Data.ByteArray as B++import Crypto.Cipher.Types+import Crypto.Hash+import Crypto.Random++import Crypto.Store.Error+import Crypto.Store.Util++checksum :: ByteArray ba => ba -> ba+checksum bs = B.convert $ B.takeView (hashWith SHA1 bs) 8++iv4adda22c79e82105 :: B.Bytes+iv4adda22c79e82105 = B.pack [0x4a, 0xdd, 0xa2, 0x2c, 0x79, 0xe8, 0x21, 0x05]++-- | Wrap an RC2 key with the specified RC2 cipher.+--+-- Input must be between 0 and 255 bytes. A fresh IV should be generated+-- randomly for each invocation.+wrap :: (MonadRandom m, BlockCipher cipher, ByteArray ba)+ => cipher -> IV cipher -> ba -> m (Either StoreError ba)+wrap = wrap' (return . Left) randomPad+ where randomPad f = fmap (Right . f) . getRandomBytes++-- | Wrap an RC2 key with the specified RC2 cipher, using the given source of+-- random padding data.+--+-- Input must be between 0 and 255 bytes. A fresh IV should be generated+-- randomly for each invocation.+wrap' :: (ByteArray ba, BlockCipher cipher)+ => (StoreError -> result) -> ((ba -> ba) -> Int -> result)+ -> cipher -> IV cipher -> ba -> result+wrap' failure withRandomPad cipher iv cek+ | inLen < 256 = withRandomPad f padlen+ | otherwise = failure+ (InvalidInput "KeyWrap.RC2: invalid length for content encryption key")+ where+ inLen = B.length cek+ padlen = (7 - inLen) `mod` 8++ f pad =+ let lcek = B.cons (fromIntegral inLen) cek+ lcekpad = B.append lcek pad+ lcekpadicv = B.append lcekpad (checksum lcekpad)+ temp1 = cbcEncrypt cipher iv lcekpadicv+ temp2 = B.append (B.convert iv) temp1+ temp3 = reverseBytes temp2+ Just iv' = makeIV iv4adda22c79e82105+ in cbcEncrypt cipher iv' temp3++-- | Unwrap an encrypted RC2 key with the specified RC2 cipher.+unwrap :: (BlockCipher cipher, ByteArray ba)+ => cipher -> ba -> Either StoreError ba+unwrap cipher wrapped+ | inLen <= 16 = invalid+ | inLen `mod` 8 /= 0 = invalid+ | checksumPadValid = Right cek+ | otherwise = invalid+ where+ inLen = B.length wrapped+ Just iv' = makeIV iv4adda22c79e82105+ temp3 = cbcDecrypt cipher iv' wrapped+ temp2 = reverseBytes temp3+ (ivBs, temp1) = B.splitAt 8 temp2+ Just iv = makeIV ivBs+ lcekpadicv = cbcDecrypt cipher iv temp1+ (lcekpad, icv) = B.splitAt (inLen - 16) lcekpadicv+ Just (l, cekpad) = B.uncons lcekpad+ len = fromIntegral l+ padlen = inLen - 16 - len - 1+ cek = B.take len cekpad+ invalid = Left BadChecksum+ checksumPadValid = B.constEq icv (checksum lcekpad)+ &&! padlen >=0 &&! padlen < 8
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/KeyWrap/TripleDES.hs view
@@ -0,0 +1,66 @@+-- |+-- Module : Crypto.Store.KeyWrap.TripleDES+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Triple-DES Key Wrap (<https://tools.ietf.org/html/rfc3217 RFC 3217>)+--+-- Should be used with a cipher from module "Crypto.Cipher.TripleDES".+module Crypto.Store.KeyWrap.TripleDES+ ( wrap+ , unwrap+ ) where++import Data.ByteArray (ByteArray)+import qualified Data.ByteArray as B++import Crypto.Cipher.Types+import Crypto.Hash++import Crypto.Store.Error+import Crypto.Store.Util++checksum :: ByteArray ba => ba -> ba+checksum bs = B.convert $ B.takeView (hashWith SHA1 bs) 8++iv4adda22c79e82105 :: B.Bytes+iv4adda22c79e82105 = B.pack [0x4a, 0xdd, 0xa2, 0x2c, 0x79, 0xe8, 0x21, 0x05]++-- | Wrap a Triple-DES key with the specified Triple-DES cipher.+--+-- Input must be 24 bytes. A fresh IV should be generated randomly for each+-- invocation.+wrap :: (BlockCipher cipher, ByteArray ba)+ => cipher -> IV cipher -> ba -> Either StoreError ba+wrap cipher iv cek+ | inLen == 24 = Right wrapped+ | otherwise = Left+ (InvalidInput "KeyWrap.TripleDES: invalid length for content encryption key")+ where+ inLen = B.length cek+ Just iv' = makeIV iv4adda22c79e82105+ cekicv = B.append cek (checksum cek)+ temp1 = cbcEncrypt cipher iv cekicv+ temp2 = B.append (B.convert iv) temp1+ temp3 = reverseBytes temp2+ wrapped = cbcEncrypt cipher iv' temp3++-- | Unwrap an encrypted Triple-DES key with the specified Triple-DES cipher.+unwrap :: (BlockCipher cipher, ByteArray ba)+ => cipher -> ba -> Either StoreError ba+unwrap cipher wrapped+ | inLen /= 40 = invalid+ | B.constEq icv (checksum cek) = Right cek+ | otherwise = invalid+ where+ inLen = B.length wrapped+ Just iv' = makeIV iv4adda22c79e82105+ temp3 = cbcDecrypt cipher iv' wrapped+ temp2 = reverseBytes temp3+ (ivBs, temp1) = B.splitAt 8 temp2+ Just iv = makeIV ivBs+ cekicv = cbcDecrypt cipher iv temp1+ (cek, icv) = B.splitAt 24 cekicv+ invalid = Left BadChecksum
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PEM.hs view
@@ -0,0 +1,35 @@+-- |+-- Module : Crypto.Store.PEM+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Extend module "Data.PEM".+module Crypto.Store.PEM+ ( readPEMs+ , writePEMs+ , pemsWriteBS+ , pemsWriteLBS+ , module Data.PEM+ ) where++import Data.PEM+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++-- | Read a PEM file from disk.+readPEMs :: FilePath -> IO [PEM]+readPEMs filepath = either error id . pemParseLBS <$> L.readFile filepath++-- | Convert a list of PEM elements to a bytestring.+pemsWriteBS :: [PEM] -> B.ByteString+pemsWriteBS = L.toStrict . pemsWriteLBS++-- | Convert a list of PEM elements to a lazy bytestring.+pemsWriteLBS :: [PEM] -> L.ByteString+pemsWriteLBS = L.concat . map pemWriteLBS++-- | Write a PEM file to disk.+writePEMs :: FilePath -> [PEM] -> IO ()+writePEMs filepath = L.writeFile filepath . pemsWriteLBS
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS12.hs view
@@ -0,0 +1,807 @@+-- |+-- Module : Crypto.Store.PKCS12+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Personal Information Exchange Syntax, aka PKCS #12.+--+-- Only password integrity mode and password privacy modes are supported.+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Crypto.Store.PKCS12+ ( IntegrityParams+ , readP12File+ , readP12FileFromMemory+ , writeP12File+ , writeP12FileToMemory+ , writeUnprotectedP12File+ , writeUnprotectedP12FileToMemory+ -- * PKCS #12 privacy+ , PKCS12+ , unPKCS12+ , unPKCS12'+ , unencrypted+ , encrypted+ -- * PKCS #12 contents and bags+ , SafeContents(..)+ , SafeBag+ , Bag(..)+ , SafeInfo(..)+ , CertInfo(..)+ , CRLInfo(..)+ , Attribute(..)+ , getSafeKeys+ , getAllSafeKeys+ , getSafeX509Certs+ , getAllSafeX509Certs+ , getSafeX509CRLs+ , getAllSafeX509CRLs+ -- * PKCS #12 attributes+ , findAttribute+ , setAttribute+ , filterAttributes+ , getFriendlyName+ , setFriendlyName+ , getLocalKeyId+ , setLocalKeyId+ -- * Credentials+ , fromCredential+ , fromNamedCredential+ , toCredential+ , toNamedCredential+ -- * Password-based protection+ , Password+ , OptAuthenticated(..)+ , recoverAuthenticated+ , ProtectionPassword+ , emptyNotTerminated+ , fromProtectionPassword+ , toProtectionPassword+ , OptProtected(..)+ , recover+ , recoverA+ ) where++import Control.Monad++import Data.ASN1.Types+import qualified Data.ByteArray as B+import qualified Data.ByteString as BS+import Data.List (partition)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Semigroup+import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509++import Crypto.Cipher.Types++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.Util+import Crypto.Store.Error+import Crypto.Store.PKCS5+import Crypto.Store.PKCS5.PBES1+import Crypto.Store.PKCS8+++-- Password-based integrity++-- | Data type for objects that are possibly authenticated with a password.+--+-- Content is verified and retrieved by providing a 'Password' value. When+-- verification is successful, a value of type 'ProtectionPassword' is also+-- returned and this value can be fed to an inner decryption layer that needs+-- the same password (usual case for PKCS #12).+data OptAuthenticated a = Unauthenticated a+ -- ^ Value is not authenticated+ | Authenticated (Password -> Either StoreError (ProtectionPassword, a))+ -- ^ Value is authenticated with a password++instance Functor OptAuthenticated where+ fmap f (Unauthenticated x) = Unauthenticated (f x)+ fmap f (Authenticated g) = Authenticated (fmap (fmap f) . g)++-- | Try to recover an 'OptAuthenticated' content using the specified password.+--+-- When successful, the content is returned, as well as the password converted+-- to type 'ProtectionPassword'. This password value can then be fed to the+-- inner decryption layer when both passwords are known to be same (usual case+-- for PKCS #12).+recoverAuthenticated :: Password -> OptAuthenticated a -> Either StoreError (ProtectionPassword, a)+recoverAuthenticated pwd (Unauthenticated x) = Right (toProtectionPassword pwd, x)+recoverAuthenticated pwd (Authenticated f) = f pwd+++-- Decoding and parsing++-- | Read a PKCS #12 file from disk.+readP12File :: FilePath -> IO (Either StoreError (OptAuthenticated PKCS12))+readP12File path = readP12FileFromMemory <$> BS.readFile path++-- | Read a PKCS #12 file from a bytearray in BER format.+readP12FileFromMemory :: BS.ByteString -> Either StoreError (OptAuthenticated PKCS12)+readP12FileFromMemory ber = decode ber >>= integrity+ where+ integrity PFX{..} =+ case macData of+ Nothing -> Unauthenticated <$> decode authSafeData+ Just md -> return $ Authenticated (verify md authSafeData)++ verify MacData{..} content pwdUTF8 =+ case digAlg of+ DigestAlgorithm d -> loop (toProtectionPasswords pwdUTF8)+ where+ -- iterate over all possible representations of a password+ -- until a successful match is found+ loop [] = Left BadContentMAC+ loop (pwd:others) =+ let fn key macAlg bs+ | not (securityAcceptable macAlg) =+ Left (InvalidParameter "Integrity MAC too weak")+ | macValue == mac macAlg key bs = (pwd,) <$> decode bs+ | otherwise = loop others+ in pkcs12mac Left fn d macParams content pwd+++-- Generating and encoding++-- | Parameters used for password integrity mode.+type IntegrityParams = (DigestAlgorithm, PBEParameter)++-- | Write a PKCS #12 file to disk.+writeP12File :: FilePath+ -> IntegrityParams -> ProtectionPassword+ -> PKCS12+ -> IO (Either StoreError ())+writeP12File path intp pw aSafe =+ case writeP12FileToMemory intp pw aSafe of+ Left e -> return (Left e)+ Right bs -> Right <$> BS.writeFile path bs++-- | Write a PKCS #12 file to a bytearray in DER format.+writeP12FileToMemory :: IntegrityParams -> ProtectionPassword+ -> PKCS12+ -> Either StoreError BS.ByteString+writeP12FileToMemory (alg@(DigestAlgorithm hashAlg), pbeParam) pwdUTF8 aSafe =+ encode <$> protect+ where+ content = encodeASN1Object aSafe+ encode md = encodeASN1Object PFX { authSafeData = content, macData = Just md }++ protect = pkcs12mac Left fn hashAlg pbeParam content pwdUTF8+ fn key macAlg bs = Right MacData { digAlg = alg+ , macValue = mac macAlg key bs+ , macParams = pbeParam+ }++-- | Write a PKCS #12 file without integrity protection to disk.+writeUnprotectedP12File :: FilePath -> PKCS12 -> IO ()+writeUnprotectedP12File path = BS.writeFile path . writeUnprotectedP12FileToMemory++-- | Write a PKCS #12 file without integrity protection to a bytearray in DER+-- format.+writeUnprotectedP12FileToMemory :: PKCS12 -> BS.ByteString+writeUnprotectedP12FileToMemory aSafe = encodeASN1Object pfx+ where+ content = encodeASN1Object aSafe+ pfx = PFX { authSafeData = content, macData = Nothing }+++-- PFX and MacData++data PFX = PFX+ { authSafeData :: BS.ByteString+ , macData :: Maybe MacData+ }+ deriving (Show,Eq)++instance ProduceASN1Object ASN1P PFX where+ asn1s PFX{..} =+ asn1Container Sequence (v . a . m)+ where+ v = gIntVal 3+ a = asn1s (DataCI authSafeData)+ m = optASN1S macData asn1s++instance ParseASN1Object [ASN1Event] PFX where+ parse = onNextContainer Sequence $ do+ IntVal v <- getNext+ when (v /= 3) $+ throwParseError ("PFX: parsed invalid version: " ++ show v)+ ci <- parse+ d <- case ci of+ DataCI bs -> return bs+ SignedDataCI _ -> throwParseError "PFX: public-key integrity mode is not supported"+ _ -> throwParseError $ "PFX: invalid content type: " ++ show (getContentType ci)+ b <- hasNext+ m <- if b then Just <$> parse else pure Nothing+ return PFX { authSafeData = d, macData = m }++data MacData = MacData+ { digAlg :: DigestAlgorithm+ , macValue :: MessageAuthenticationCode+ , macParams :: PBEParameter+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e MacData where+ asn1s MacData{..} =+ asn1Container Sequence (m . s . i)+ where+ m = asn1Container Sequence (a . v)+ a = algorithmASN1S Sequence digAlg+ v = gOctetString (B.convert macValue)+ s = gOctetString (pbeSalt macParams)+ i = gIntVal (fromIntegral $ pbeIterationCount macParams)++instance Monoid e => ParseASN1Object e MacData where+ parse = onNextContainer Sequence $ do+ (a, v) <- onNextContainer Sequence $ do+ a <- parseAlgorithm Sequence+ OctetString v <- getNext+ return (a, v)+ OctetString s <- getNext+ b <- hasNext+ IntVal i <- if b then getNext else pure (IntVal 1)+ return MacData { digAlg = a+ , macValue = AuthTag (B.convert v)+ , macParams = PBEParameter s (fromIntegral i)+ }+++-- AuthenticatedSafe++-- | PKCS #12 privacy wrapper, adding optional encryption to 'SafeContents'.+-- ASN.1 equivalent is @AuthenticatedSafe@.+--+-- The semigroup interface allows to combine multiple pieces encrypted+-- separately but they should all derive from the same password to be readable+-- by 'unPKCS12' and most other software.+newtype PKCS12 = PKCS12 [ASElement]+ deriving (Show,Eq)++instance Semigroup PKCS12 where+ PKCS12 a <> PKCS12 b = PKCS12 (a ++ b)++instance ProduceASN1Object ASN1P PKCS12 where+ asn1s (PKCS12 elems) = asn1Container Sequence (asn1s elems)++instance ParseASN1Object [ASN1Event] PKCS12 where+ parse = PKCS12 <$> onNextContainer Sequence parse++-- | Read the contents of a PKCS #12. The same privacy password will be used+-- for all content elements.+--+-- This convenience function returns a 'Protected' value as soon as one element+-- at least is encrypted. This does not mean all elements were actually+-- protected in the input. If detailed view is required then function+-- 'unPKCS12'' is also available.+unPKCS12 :: PKCS12 -> OptProtected [SafeContents]+unPKCS12 = applySamePassword . unPKCS12'++-- | Read the contents of a PKCS #12.+unPKCS12' :: PKCS12 -> [OptProtected SafeContents]+unPKCS12' (PKCS12 elems) = map f elems+ where f (Unencrypted sc) = Unprotected sc+ f (Encrypted e) = Protected (decrypt e >=> decode)++-- | Build a PKCS #12 without encryption. Usage scenario is when private keys+-- are already encrypted with 'PKCS8ShroudedKeyBag'.+unencrypted :: SafeContents -> PKCS12+unencrypted = PKCS12 . (:[]) . Unencrypted++-- | Build a PKCS #12 encrypted with the specified scheme and password.+encrypted :: EncryptionScheme -> ProtectionPassword -> SafeContents -> Either StoreError PKCS12+encrypted alg pwd sc = PKCS12 . (:[]) . Encrypted <$> encrypt alg pwd bs+ where bs = encodeASN1Object sc++data ASElement = Unencrypted SafeContents+ | Encrypted PKCS5+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e ASElement where+ asn1s (Unencrypted sc) = asn1Container Sequence (oid . cont)+ where+ oid = gOID (getObjectID DataType)+ cont = asn1Container (Container Context 0) (gOctetString bs)+ bs = encodeASN1Object sc++ asn1s (Encrypted PKCS5{..}) = asn1Container Sequence (oid . cont)+ where+ oid = gOID (getObjectID EncryptedDataType)+ cont = asn1Container (Container Context 0) inner+ inner = asn1Container Sequence (gIntVal 0 . eci)+ eci = encryptedContentInfoASN1S+ (DataType, encryptionAlgorithm, Attached encryptedData)++instance Monoid e => ParseASN1Object e ASElement where+ parse = onNextContainer Sequence $ do+ OID oid <- getNext+ withObjectID "content type" oid $ \ct ->+ onNextContainer (Container Context 0) (parseInner ct)+ where+ parseInner DataType = Unencrypted <$> parseUnencrypted+ parseInner EncryptedDataType = Encrypted <$> parseEncrypted+ parseInner EnvelopedDataType = throwParseError "PKCS12: public-key privacy mode is not supported"+ parseInner ct = throwParseError $ "PKCS12: invalid content type: " ++ show ct++ parseUnencrypted = parseOctetStringObject "PKCS12"+ parseEncrypted = onNextContainer Sequence $ do+ IntVal 0 <- getNext+ (DataType, eScheme, Attached ed) <- parseEncryptedContentInfo+ return PKCS5 { encryptionAlgorithm = eScheme, encryptedData = ed }+++-- Bags++-- | Polymorphic PKCS #12 bag parameterized by the payload data type.+data Bag info = Bag+ { bagInfo :: info -- ^ bag payload+ , bagAttributes :: [Attribute] -- ^ attributes providing additional information+ }+ deriving (Show,Eq)++class BagInfo info where+ type BagType info+ bagName :: info -> String+ bagType :: info -> BagType info+ valueASN1S :: ASN1Elem e => info -> ASN1Stream e+ parseValue :: Monoid e => BagType info -> ParseASN1 e info++instance (ASN1Elem e, BagInfo info, OIDable (BagType info)) => ProduceASN1Object e (Bag info) where+ asn1s Bag{..} = asn1Container Sequence (oid . val . att)+ where+ typ = bagType bagInfo+ oid = gOID (getObjectID typ)+ val = asn1Container (Container Context 0) (valueASN1S bagInfo)++ att | null bagAttributes = id+ | otherwise = asn1Container Set (asn1s bagAttributes)++instance (Monoid e, BagInfo info, OIDNameable (BagType info)) => ParseASN1Object e (Bag info) where+ parse = onNextContainer Sequence $ do+ OID oid <- getNext+ val <- withObjectID (getName undefined) oid $+ onNextContainer (Container Context 0) . parseValue+ att <- fromMaybe [] <$> onNextContainerMaybe Set parse+ return Bag { bagInfo = val, bagAttributes = att }+ where+ getName :: info -> String+ getName = bagName++data CertType = TypeCertX509 deriving (Show,Eq)++instance Enumerable CertType where+ values = [ TypeCertX509 ]++instance OIDable CertType where+ getObjectID TypeCertX509 = [1,2,840,113549,1,9,22,1]++instance OIDNameable CertType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Certificate bags. Only X.509 certificates are supported.+newtype CertInfo = CertX509 X509.SignedCertificate deriving (Show,Eq)++instance BagInfo CertInfo where+ type BagType CertInfo = CertType+ bagName _ = "CertBag"+ bagType (CertX509 _) = TypeCertX509+ valueASN1S (CertX509 c) = gOctetString (encodeASN1Object c)+ parseValue TypeCertX509 = CertX509 <$> parseOctetStringObject "CertBag"++data CRLType = TypeCRLX509 deriving (Show,Eq)++instance Enumerable CRLType where+ values = [ TypeCRLX509 ]++instance OIDable CRLType where+ getObjectID TypeCRLX509 = [1,2,840,113549,1,9,23,1]++instance OIDNameable CRLType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | CRL bags. Only X.509 CRLs are supported.+newtype CRLInfo = CRLX509 X509.SignedCRL deriving (Show,Eq)++instance BagInfo CRLInfo where+ type BagType CRLInfo = CRLType+ bagName _ = "CRLBag"+ bagType (CRLX509 _) = TypeCRLX509+ valueASN1S (CRLX509 c) = gOctetString (encodeASN1Object c)+ parseValue TypeCRLX509 = CRLX509 <$> parseOctetStringObject "CRLBag"++data SafeType = TypeKey+ | TypePKCS8ShroudedKey+ | TypeCert+ | TypeCRL+ | TypeSecret+ | TypeSafeContents+ deriving (Show,Eq)++instance Enumerable SafeType where+ values = [ TypeKey+ , TypePKCS8ShroudedKey+ , TypeCert+ , TypeCRL+ , TypeSecret+ , TypeSafeContents+ ]++instance OIDable SafeType where+ getObjectID TypeKey = [1,2,840,113549,1,12,10,1,1]+ getObjectID TypePKCS8ShroudedKey = [1,2,840,113549,1,12,10,1,2]+ getObjectID TypeCert = [1,2,840,113549,1,12,10,1,3]+ getObjectID TypeCRL = [1,2,840,113549,1,12,10,1,4]+ getObjectID TypeSecret = [1,2,840,113549,1,12,10,1,5]+ getObjectID TypeSafeContents = [1,2,840,113549,1,12,10,1,6]++instance OIDNameable SafeType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Main bag payload in PKCS #12 contents.+data SafeInfo = KeyBag (FormattedKey X509.PrivKey) -- ^ unencrypted private key+ | PKCS8ShroudedKeyBag PKCS5 -- ^ encrypted private key+ | CertBag (Bag CertInfo) -- ^ certificate+ | CRLBag (Bag CRLInfo) -- ^ CRL+ | SecretBag [ASN1] -- ^ arbitrary secret+ | SafeContentsBag SafeContents -- ^ safe contents embeded recursively+ deriving (Show,Eq)++instance BagInfo SafeInfo where+ type BagType SafeInfo = SafeType+ bagName _ = "SafeBag"++ bagType (KeyBag _) = TypeKey+ bagType (PKCS8ShroudedKeyBag _) = TypePKCS8ShroudedKey+ bagType (CertBag _) = TypeCert+ bagType (CRLBag _) = TypeCRL+ bagType (SecretBag _) = TypeSecret+ bagType (SafeContentsBag _) = TypeSafeContents++ valueASN1S (KeyBag k) = asn1s k+ valueASN1S (PKCS8ShroudedKeyBag k) = asn1s k+ valueASN1S (CertBag c) = asn1s c+ valueASN1S (CRLBag c) = asn1s c+ valueASN1S (SecretBag s) = gMany s+ valueASN1S (SafeContentsBag sc) = asn1s sc++ parseValue TypeKey = KeyBag <$> parse+ parseValue TypePKCS8ShroudedKey = PKCS8ShroudedKeyBag <$> parse+ parseValue TypeCert = CertBag <$> parse+ parseValue TypeCRL = CRLBag <$> parse+ parseValue TypeSecret = SecretBag <$> getMany getNext+ parseValue TypeSafeContents = SafeContentsBag <$> parse++-- | Main bag type in a PKCS #12.+type SafeBag = Bag SafeInfo++-- | Content objects stored in a PKCS #12.+newtype SafeContents = SafeContents { unSafeContents :: [SafeBag] }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e SafeContents where+ asn1s (SafeContents s) = asn1Container Sequence (asn1s s)++instance Monoid e => ParseASN1Object e SafeContents where+ parse = SafeContents <$> onNextContainer Sequence parse++filterBags :: ([Attribute] -> Bool) -> SafeContents -> SafeContents+filterBags p (SafeContents scs) = SafeContents (mapMaybe f scs)+ where+ f (Bag (SafeContentsBag inner) attrs) =+ Just (Bag (SafeContentsBag $ filterBags p inner) attrs)+ f bag | p (bagAttributes bag) = Just bag+ | otherwise = Nothing++filterByFriendlyName :: String -> SafeContents -> SafeContents+filterByFriendlyName name = filterBags ((== Just name) . getFriendlyName)++filterByLocalKeyId :: BS.ByteString -> SafeContents -> SafeContents+filterByLocalKeyId d = filterBags ((== Just d) . getLocalKeyId)++getSafeKeysId :: SafeContents -> [OptProtected (Id X509.PrivKey)]+getSafeKeysId (SafeContents scs) = loop scs+ where+ loop [] = []+ loop (bag : bags) =+ case bagInfo bag of+ KeyBag (FormattedKey _ k) -> Unprotected (mkId k bag) : loop bags+ PKCS8ShroudedKeyBag k -> Protected (unshroud k bag) : loop bags+ SafeContentsBag inner -> getSafeKeysId inner ++ loop bags+ _ -> loop bags++ unshroud shrouded bag pwd = do+ bs <- decrypt shrouded pwd+ FormattedKey _ k <- decode bs+ return (mkId k bag)++-- | Return all private keys contained in the safe contents.+getSafeKeys :: SafeContents -> [OptProtected X509.PrivKey]+getSafeKeys = map (fmap unId) . getSafeKeysId++getAllSafeKeysId :: [SafeContents] -> OptProtected [Id X509.PrivKey]+getAllSafeKeysId = applySamePassword . concatMap getSafeKeysId++-- | Return all private keys contained in the safe content list. All shrouded+-- private keys must derive from the same password.+--+-- This convenience function returns a 'Protected' value as soon as one key at+-- least is encrypted. This does not mean all keys were actually protected in+-- the input. If detailed view is required then function 'getSafeKeys' is+-- available.+getAllSafeKeys :: [SafeContents] -> OptProtected [X509.PrivKey]+getAllSafeKeys = applySamePassword . concatMap getSafeKeys++getSafeX509CertsId :: SafeContents -> [Id X509.SignedCertificate]+getSafeX509CertsId (SafeContents scs) = loop scs+ where+ loop [] = []+ loop (bag : bags) =+ case bagInfo bag of+ CertBag (Bag (CertX509 c) _) -> mkId c bag : loop bags+ SafeContentsBag inner -> getSafeX509CertsId inner ++ loop bags+ _ -> loop bags++-- | Return all X.509 certificates contained in the safe contents.+getSafeX509Certs :: SafeContents -> [X509.SignedCertificate]+getSafeX509Certs = map unId . getSafeX509CertsId++-- | Return all X.509 certificates contained in the safe content list.+getAllSafeX509Certs :: [SafeContents] -> [X509.SignedCertificate]+getAllSafeX509Certs = concatMap getSafeX509Certs++getSafeX509CRLsId :: SafeContents -> [Id X509.SignedCRL]+getSafeX509CRLsId (SafeContents scs) = loop scs+ where+ loop [] = []+ loop (bag : bags) =+ case bagInfo bag of+ CRLBag (Bag (CRLX509 c) _) -> mkId c bag : loop bags+ SafeContentsBag inner -> getSafeX509CRLsId inner ++ loop bags+ _ -> loop bags++-- | Return all X.509 CRLs contained in the safe contents.+getSafeX509CRLs :: SafeContents -> [X509.SignedCRL]+getSafeX509CRLs = map unId . getSafeX509CRLsId++-- | Return all X.509 CRLs contained in the safe content list.+getAllSafeX509CRLs :: [SafeContents] -> [X509.SignedCRL]+getAllSafeX509CRLs = concatMap getSafeX509CRLs+++-- Conversion to/from credentials++getInnerCredential :: [SafeContents] -> SamePassword (Maybe (X509.CertificateChain, X509.PrivKey))+getInnerCredential l = SamePassword (fn <$> getAllSafeKeysId l)+ where+ certs = getAllSafeX509Certs l+ fn idKeys = do+ iKey <- single idKeys+ let k = unId iKey+ case idKeyId iKey of+ Just d -> do+ -- locate a single certificate with same ID as private key+ -- and follow the issuers to get all certificates in the chain+ let filtered = map (filterByLocalKeyId d) l+ leaf <- single (getAllSafeX509Certs filtered)+ pure (buildCertificateChain leaf certs, k)+ Nothing ->+ case idName iKey of+ Just name -> do+ -- same but using friendly name of private key+ let filtered = map (filterByFriendlyName name) l+ leaf <- single (getAllSafeX509Certs filtered)+ pure (buildCertificateChain leaf certs, k)+ Nothing -> do+ -- no identifier available, so we simply return all+ -- certificates with input order+ guard (not $ null certs)+ pure (X509.CertificateChain certs, k)++-- | Extract the private key and certificate chain from a 'PKCS12' value. A+-- credential is returned when the structure contains exactly one private key+-- and at least one X.509 certificate.+toCredential :: PKCS12 -> OptProtected (Maybe (X509.CertificateChain, X509.PrivKey))+toCredential p12 =+ unSamePassword (SamePassword (unPKCS12 p12) >>= getInnerCredential)++getInnerCredentialNamed :: String -> [SafeContents] -> SamePassword (Maybe (X509.CertificateChain, X509.PrivKey))+getInnerCredentialNamed name l = SamePassword (fn <$> getAllSafeKeys filtered)+ where+ certs = getAllSafeX509Certs l+ filtered = map (filterByFriendlyName name) l+ fn keys = do+ k <- single keys+ leaf <- single (getAllSafeX509Certs filtered)+ pure (buildCertificateChain leaf certs, k)++-- | Extract a private key and certificate chain with the specified friendly+-- name from a 'PKCS12' value. A credential is returned when the structure+-- contains exactly one private key and one X.509 certificate with the name.+toNamedCredential :: String -> PKCS12 -> OptProtected (Maybe (X509.CertificateChain, X509.PrivKey))+toNamedCredential name p12 = unSamePassword $+ SamePassword (unPKCS12 p12) >>= getInnerCredentialNamed name++-- | Build a 'PKCS12' value containing a private key and certificate chain.+-- Distinct encryption is applied for both. Encrypting the certificate chain is+-- optional.+--+-- Note: advice is to always generate fresh and independent 'EncryptionScheme'+-- values so that the salt is not reused twice in the encryption process.+fromCredential :: Maybe EncryptionScheme -- for certificates+ -> EncryptionScheme -- for private key+ -> ProtectionPassword+ -> (X509.CertificateChain, X509.PrivKey)+ -> Either StoreError PKCS12+fromCredential = fromCredential' id++-- | Build a 'PKCS12' value containing a private key and certificate chain+-- identified with the specified friendly name. Distinct encryption is applied+-- for private key and certificates. Encrypting the certificate chain is+-- optional.+--+-- Note: advice is to always generate fresh and independent 'EncryptionScheme'+-- values so that the salt is not reused twice in the encryption process.+fromNamedCredential :: String+ -> Maybe EncryptionScheme -- for certificates+ -> EncryptionScheme -- for private key+ -> ProtectionPassword+ -> (X509.CertificateChain, X509.PrivKey)+ -> Either StoreError PKCS12+fromNamedCredential name = fromCredential' (setFriendlyName name)++fromCredential' :: ([Attribute] -> [Attribute])+ -> Maybe EncryptionScheme -- for certificates+ -> EncryptionScheme -- for private key+ -> ProtectionPassword+ -> (X509.CertificateChain, X509.PrivKey)+ -> Either StoreError PKCS12+fromCredential' trans algChain algKey pwd (X509.CertificateChain certs, key)+ | null certs = Left (InvalidInput "Empty certificate chain")+ | otherwise = (<>) <$> pkcs12Chain <*> pkcs12Key+ where+ pkcs12Key = unencrypted <$> scKeyOrError+ pkcs12Chain =+ case algChain of+ Just alg -> encrypted alg pwd scChain+ Nothing -> Right (unencrypted scChain)++ scChain = SafeContents (zipWith toCertBag certAttrs certs)+ certAttrs = attrs : repeat []+ toCertBag a c = Bag (CertBag (Bag (CertX509 c) [])) a++ scKeyOrError = wrap <$> encrypt algKey pwd encodedKey++ wrap shrouded = SafeContents [Bag (PKCS8ShroudedKeyBag shrouded) attrs]+ encodedKey = encodeASN1Object (FormattedKey PKCS8Format key)++ X509.Fingerprint keyId = X509.getFingerprint (head certs) X509.HashSHA1+ attrs = trans (setLocalKeyId keyId [])++-- Standard attributes++friendlyName :: OID+friendlyName = [1,2,840,113549,1,9,20]++-- | Return the value of the @friendlyName@ attribute.+getFriendlyName :: [Attribute] -> Maybe String+getFriendlyName attrs = runParseAttribute friendlyName attrs $ do+ ASN1String str <- getNext+ case asn1CharacterToString str of+ Nothing -> throwParseError "Invalid friendlyName value"+ Just s -> return s++-- | Add or replace the @friendlyName@ attribute in a list of attributes.+setFriendlyName :: String -> [Attribute] -> [Attribute]+setFriendlyName name = setAttributeASN1S friendlyName (gBMPString name)++localKeyId :: OID+localKeyId = [1,2,840,113549,1,9,21]++-- | Return the value of the @localKeyId@ attribute.+getLocalKeyId :: [Attribute] -> Maybe BS.ByteString+getLocalKeyId attrs = runParseAttribute localKeyId attrs $ do+ OctetString d <- getNext+ return d++-- | Add or replace the @localKeyId@ attribute in a list of attributes.+setLocalKeyId :: BS.ByteString -> [Attribute] -> [Attribute]+setLocalKeyId d = setAttributeASN1S localKeyId (gOctetString d)+++-- Utilities++-- Internal wrapper of OptProtected providing Applicative and Monad instances.+--+-- This adds the following constraint: all values composed must derive from the+-- same encryption password. Semantically, 'Protected' actually means+-- "requiring a password". Otherwise composition of 'Protected' and+-- 'Unprotected' values is unsound.+newtype SamePassword a = SamePassword { unSamePassword :: OptProtected a }++instance Functor SamePassword where+ fmap f (SamePassword opt) = SamePassword (fmap f opt)++instance Applicative SamePassword where+ pure a = SamePassword (Unprotected a)++ SamePassword (Unprotected f) <*> SamePassword (Unprotected x) =+ SamePassword (Unprotected (f x))++ SamePassword (Unprotected f) <*> SamePassword (Protected x) =+ SamePassword $ Protected (fmap f . x)++ SamePassword (Protected f) <*> SamePassword (Unprotected x) =+ SamePassword $ Protected (fmap ($ x) . f)++ SamePassword (Protected f) <*> SamePassword (Protected x) =+ SamePassword $ Protected (\pwd -> f pwd <*> x pwd)++instance Monad SamePassword where+ return = pure++ SamePassword (Unprotected x) >>= f = f x+ SamePassword (Protected inner) >>= f =+ SamePassword . Protected $ \pwd ->+ case inner pwd of+ Left err -> Left err+ Right x -> recover pwd (unSamePassword $ f x)++applySamePassword :: [OptProtected a] -> OptProtected [a]+applySamePassword = unSamePassword . traverse SamePassword++single :: [a] -> Maybe a+single [x] = Just x+single _ = Nothing++data Id a = Id+ { unId :: a+ , idKeyId :: Maybe BS.ByteString+ , idName :: Maybe String+ }++mkId :: a -> Bag info -> Id a+mkId val bag = val `seq` Id val (getLocalKeyId attrs) (getFriendlyName attrs)+ where attrs = bagAttributes bag++decode :: ParseASN1Object [ASN1Event] obj => BS.ByteString -> Either StoreError obj+decode = decodeASN1Object++parseOctetStringObject :: (Monoid e, ParseASN1Object [ASN1Event] obj)+ => String -> ParseASN1 e obj+parseOctetStringObject name = do+ bs <- parseOctetString+ case decode bs of+ Left e -> throwParseError (name ++ ": " ++ show e)+ Right c -> return c++buildCertificateChain :: X509.SignedCertificate -> [X509.SignedCertificate]+ -> X509.CertificateChain+buildCertificateChain leaf authorities =+ X509.CertificateChain (leaf : findAuthorities leaf authorities)+ where+ findAuthorities cert others+ | subject cert == issuer cert = []+ | otherwise =+ case partition (\c -> subject c == issuer cert) others of+ ([c], others') -> c : findAuthorities c others'+ _ -> []++ signedCert = X509.signedObject . X509.getSigned++ subject c = X509.certSubjectDN (signedCert c)+ issuer c = X509.certIssuerDN (signedCert c)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS5.hs view
@@ -0,0 +1,238 @@+-- |+-- Module : Data.Store.PKCS5+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Password-Based Cryptography, aka PKCS #5.+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Crypto.Store.PKCS5+ ( ProtectionPassword+ , emptyNotTerminated+ , fromProtectionPassword+ , toProtectionPassword+ , EncryptedContent+ -- * High-level API+ , PKCS5(..)+ , encrypt+ , decrypt+ -- * Encryption schemes+ , EncryptionScheme(..)+ , PBEParameter(..)+ , PBES2Parameter(..)+ -- * Key derivation+ , KeyDerivationFunc(..)+ , PBKDF2_PRF(..)+ , Salt+ , generateSalt+ -- * Content encryption+ , ContentEncryptionParams+ , ContentEncryptionAlg(..)+ , ContentEncryptionCipher(..)+ , generateEncryptionParams+ , getContentEncryptionAlg+ -- * Low-level API+ , pbEncrypt+ , pbDecrypt+ ) where++import Data.ASN1.Types+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)++import Crypto.Store.ASN1.Parse+import Crypto.Store.ASN1.Generate+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Encrypted+import Crypto.Store.CMS.Util+import Crypto.Store.Error+import Crypto.Store.PKCS5.PBES1++data EncryptionSchemeType = Type_PBES2+ | Type_PBE_MD5_DES_CBC+ | Type_PBE_SHA1_DES_CBC+ | Type_PBE_SHA1_RC4_128+ | Type_PBE_SHA1_RC4_40+ | Type_PBE_SHA1_DES_EDE3_CBC+ | Type_PBE_SHA1_DES_EDE2_CBC+ | Type_PBE_SHA1_RC2_128+ | Type_PBE_SHA1_RC2_40++instance Enumerable EncryptionSchemeType where+ values = [ Type_PBES2+ , Type_PBE_MD5_DES_CBC+ , Type_PBE_SHA1_DES_CBC+ , Type_PBE_SHA1_RC4_128+ , Type_PBE_SHA1_RC4_40+ , Type_PBE_SHA1_DES_EDE3_CBC+ , Type_PBE_SHA1_DES_EDE2_CBC+ , Type_PBE_SHA1_RC2_128+ , Type_PBE_SHA1_RC2_40+ ]++instance OIDable EncryptionSchemeType where+ getObjectID Type_PBES2 = [1,2,840,113549,1,5,13]+ getObjectID Type_PBE_MD5_DES_CBC = [1,2,840,113549,1,5,3]+ getObjectID Type_PBE_SHA1_DES_CBC = [1,2,840,113549,1,5,10]+ getObjectID Type_PBE_SHA1_RC4_128 = [1,2,840,113549,1,12,1,1]+ getObjectID Type_PBE_SHA1_RC4_40 = [1,2,840,113549,1,12,1,2]+ getObjectID Type_PBE_SHA1_DES_EDE3_CBC = [1,2,840,113549,1,12,1,3]+ getObjectID Type_PBE_SHA1_DES_EDE2_CBC = [1,2,840,113549,1,12,1,4]+ getObjectID Type_PBE_SHA1_RC2_128 = [1,2,840,113549,1,12,1,5]+ getObjectID Type_PBE_SHA1_RC2_40 = [1,2,840,113549,1,12,1,6]++instance OIDNameable EncryptionSchemeType where+ fromObjectID oid = unOIDNW <$> fromObjectID oid++-- | Password-Based Encryption Scheme (PBES).+data EncryptionScheme = PBES2 PBES2Parameter -- ^ PBES2+ | PBE_MD5_DES_CBC PBEParameter -- ^ pbeWithMD5AndDES-CBC+ | PBE_SHA1_DES_CBC PBEParameter -- ^ pbeWithSHA1AndDES-CBC+ | PBE_SHA1_RC4_128 PBEParameter -- ^ pbeWithSHAAnd128BitRC4+ | PBE_SHA1_RC4_40 PBEParameter -- ^ pbeWithSHAAnd40BitRC4+ | PBE_SHA1_DES_EDE3_CBC PBEParameter -- ^ pbeWithSHAAnd3-KeyTripleDES-CBC+ | PBE_SHA1_DES_EDE2_CBC PBEParameter -- ^ pbeWithSHAAnd2-KeyTripleDES-CBC+ | PBE_SHA1_RC2_128 PBEParameter -- ^ pbeWithSHAAnd128BitRC2-CBC+ | PBE_SHA1_RC2_40 PBEParameter -- ^ pbewithSHAAnd40BitRC2-CBC+ deriving (Show,Eq)++-- | PBES2 parameters.+data PBES2Parameter = PBES2Parameter+ { pbes2KDF :: KeyDerivationFunc -- ^ Key derivation function+ , pbes2EScheme :: ContentEncryptionParams -- ^ Underlying encryption scheme+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e PBES2Parameter where+ asn1s PBES2Parameter{..} =+ let kdFunc = algorithmASN1S Sequence pbes2KDF+ eScheme = asn1s pbes2EScheme+ in asn1Container Sequence (kdFunc . eScheme)++instance Monoid e => ParseASN1Object e PBES2Parameter where+ parse = onNextContainer Sequence $ do+ kdFunc <- parseAlgorithm Sequence+ eScheme <- parse+ case kdfKeyLength kdFunc of+ Nothing -> return ()+ Just sz+ | validateKeySize eScheme sz -> return ()+ | otherwise -> throwParseError "PBES2Parameter: parsed key length incompatible with encryption scheme"+ return PBES2Parameter { pbes2KDF = kdFunc, pbes2EScheme = eScheme }++instance AlgorithmId EncryptionScheme where+ type AlgorithmType EncryptionScheme = EncryptionSchemeType+ algorithmName _ = "encryption scheme"++ algorithmType (PBES2 _) = Type_PBES2+ algorithmType (PBE_MD5_DES_CBC _) = Type_PBE_MD5_DES_CBC+ algorithmType (PBE_SHA1_DES_CBC _) = Type_PBE_SHA1_DES_CBC+ algorithmType (PBE_SHA1_RC4_128 _) = Type_PBE_SHA1_RC4_128+ algorithmType (PBE_SHA1_RC4_40 _) = Type_PBE_SHA1_RC4_40+ algorithmType (PBE_SHA1_DES_EDE3_CBC _) = Type_PBE_SHA1_DES_EDE3_CBC+ algorithmType (PBE_SHA1_DES_EDE2_CBC _) = Type_PBE_SHA1_DES_EDE2_CBC+ algorithmType (PBE_SHA1_RC2_128 _) = Type_PBE_SHA1_RC2_128+ algorithmType (PBE_SHA1_RC2_40 _) = Type_PBE_SHA1_RC2_40++ parameterASN1S (PBES2 p) = asn1s p+ parameterASN1S (PBE_MD5_DES_CBC p) = asn1s p+ parameterASN1S (PBE_SHA1_DES_CBC p) = asn1s p+ parameterASN1S (PBE_SHA1_RC4_128 p) = asn1s p+ parameterASN1S (PBE_SHA1_RC4_40 p) = asn1s p+ parameterASN1S (PBE_SHA1_DES_EDE3_CBC p) = asn1s p+ parameterASN1S (PBE_SHA1_DES_EDE2_CBC p) = asn1s p+ parameterASN1S (PBE_SHA1_RC2_128 p) = asn1s p+ parameterASN1S (PBE_SHA1_RC2_40 p) = asn1s p++ parseParameter Type_PBES2 = PBES2 <$> parse+ parseParameter Type_PBE_MD5_DES_CBC = PBE_MD5_DES_CBC <$> parse+ parseParameter Type_PBE_SHA1_DES_CBC = PBE_SHA1_DES_CBC <$> parse+ parseParameter Type_PBE_SHA1_RC4_128 = PBE_SHA1_RC4_128 <$> parse+ parseParameter Type_PBE_SHA1_RC4_40 = PBE_SHA1_RC4_40 <$> parse+ parseParameter Type_PBE_SHA1_DES_EDE3_CBC = PBE_SHA1_DES_EDE3_CBC <$> parse+ parseParameter Type_PBE_SHA1_DES_EDE2_CBC = PBE_SHA1_DES_EDE2_CBC <$> parse+ parseParameter Type_PBE_SHA1_RC2_128 = PBE_SHA1_RC2_128 <$> parse+ parseParameter Type_PBE_SHA1_RC2_40 = PBE_SHA1_RC2_40 <$> parse++instance ASN1Elem e => ProduceASN1Object e EncryptionScheme where+ asn1s = algorithmASN1S Sequence++instance Monoid e => ParseASN1Object e EncryptionScheme where+ parse = parseAlgorithm Sequence+++-- High-level API++-- | Content encrypted with a Password-Based Encryption Scheme (PBES).+--+-- The content will usually be the binary representation of an ASN.1 object,+-- however the transformation may be applied to any bytestring.+data PKCS5 = PKCS5+ { encryptionAlgorithm :: EncryptionScheme -- ^ Scheme used to encrypt content+ , encryptedData :: EncryptedContent -- ^ Encrypted content+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e PKCS5 where+ asn1s PKCS5{..} = asn1Container Sequence (alg . bs)+ where alg = asn1s encryptionAlgorithm+ bs = gOctetString encryptedData++instance Monoid e => ParseASN1Object e PKCS5 where+ parse = onNextContainer Sequence $ do+ alg <- parse+ OctetString bs <- getNext+ return PKCS5 { encryptionAlgorithm = alg, encryptedData = bs }++instance ASN1Object PKCS5 where+ toASN1 = asn1s+ fromASN1 = runParseASN1State parse++-- | Encrypt a bytestring with the specified encryption scheme and password.+encrypt :: EncryptionScheme -> ProtectionPassword -> ByteString -> Either StoreError PKCS5+encrypt alg pwd bs = build <$> pbEncrypt alg bs pwd+ where+ build ed = ed `seq` PKCS5 { encryptionAlgorithm = alg, encryptedData = ed }++-- | Decrypt the PKCS #5 content with the specified password.+decrypt :: PKCS5 -> ProtectionPassword -> Either StoreError ByteString+decrypt obj = pbDecrypt (encryptionAlgorithm obj) (encryptedData obj)+++-- Encryption Schemes++-- | Encrypt a bytestring with the specified encryption scheme and password.+pbEncrypt :: EncryptionScheme -> ByteString -> ProtectionPassword+ -> Either StoreError EncryptedContent+pbEncrypt (PBES2 p) = pbes2 contentEncrypt p+pbEncrypt (PBE_MD5_DES_CBC p) = pkcs5 Left contentEncrypt MD5 DES p+pbEncrypt (PBE_SHA1_DES_CBC p) = pkcs5 Left contentEncrypt SHA1 DES p+pbEncrypt (PBE_SHA1_RC4_128 p) = pkcs12stream Left rc4Combine SHA1 16 p+pbEncrypt (PBE_SHA1_RC4_40 p) = pkcs12stream Left rc4Combine SHA1 5 p+pbEncrypt (PBE_SHA1_DES_EDE3_CBC p) = pkcs12 Left contentEncrypt SHA1 DES_EDE3 p+pbEncrypt (PBE_SHA1_DES_EDE2_CBC p) = pkcs12 Left contentEncrypt SHA1 DES_EDE2 p+pbEncrypt (PBE_SHA1_RC2_128 p) = pkcs12rc2 Left contentEncrypt SHA1 128 p+pbEncrypt (PBE_SHA1_RC2_40 p) = pkcs12rc2 Left contentEncrypt SHA1 40 p++-- | Decrypt an encrypted bytestring with the specified encryption scheme and+-- password.+pbDecrypt :: EncryptionScheme -> EncryptedContent -> ProtectionPassword -> Either StoreError ByteString+pbDecrypt (PBES2 p) = pbes2 contentDecrypt p+pbDecrypt (PBE_MD5_DES_CBC p) = pkcs5 Left contentDecrypt MD5 DES p+pbDecrypt (PBE_SHA1_DES_CBC p) = pkcs5 Left contentDecrypt SHA1 DES p+pbDecrypt (PBE_SHA1_RC4_128 p) = pkcs12stream Left rc4Combine SHA1 16 p+pbDecrypt (PBE_SHA1_RC4_40 p) = pkcs12stream Left rc4Combine SHA1 5 p+pbDecrypt (PBE_SHA1_DES_EDE3_CBC p) = pkcs12 Left contentDecrypt SHA1 DES_EDE3 p+pbDecrypt (PBE_SHA1_DES_EDE2_CBC p) = pkcs12 Left contentDecrypt SHA1 DES_EDE2 p+pbDecrypt (PBE_SHA1_RC2_128 p) = pkcs12rc2 Left contentDecrypt SHA1 128 p+pbDecrypt (PBE_SHA1_RC2_40 p) = pkcs12rc2 Left contentDecrypt SHA1 40 p++pbes2 :: (Key -> ContentEncryptionParams -> ByteString -> result)+ -> PBES2Parameter -> ByteString -> ProtectionPassword -> result+pbes2 encdec PBES2Parameter{..} bs pwd = encdec key pbes2EScheme bs+ where key = kdfDerive pbes2KDF len (fromProtectionPassword pwd) :: Key+ len = fromMaybe (getMaximumKeySize pbes2EScheme) (kdfKeyLength pbes2KDF)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS5/PBES1.hs view
@@ -0,0 +1,418 @@+-- |+-- Module : Data.Store.PKCS5.PBES1+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Password-Based Encryption Schemes+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Crypto.Store.PKCS5.PBES1+ ( PBEParameter(..)+ , Key+ , ProtectionPassword+ , emptyNotTerminated+ , fromProtectionPassword+ , toProtectionPassword+ , toProtectionPasswords+ , pkcs5+ , pkcs12+ , pkcs12rc2+ , pkcs12stream+ , pkcs12mac+ , rc4Combine+ ) where++import Basement.Block (Block)+import Basement.Compat.IsList+import Basement.Endianness+import qualified Basement.String as S++import Crypto.Cipher.Types+import qualified Crypto.Cipher.RC4 as RC4+import qualified Crypto.Hash as Hash++import Data.ASN1.Types+import Data.Bits+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as B+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Data.Memory.PtrMethods+import Data.String (IsString(..))+import Data.Word++import Foreign.Ptr (plusPtr)+import Foreign.Storable++import Crypto.Store.ASN1.Parse+import Crypto.Store.ASN1.Generate+import Crypto.Store.CMS.Algorithms+import Crypto.Store.CMS.Util+import Crypto.Store.Error++-- | A password stored as a sequence of UTF-8 bytes.+--+-- Some key-derivation functions add restrictions to what characters+-- are supported.+--+-- The data type provides a special value 'emptyNotTerminated' that is used+-- as alternate representation of empty passwords on some systems and that+-- produces encryption results different than an empty bytearray.+--+-- Conversion to/from a regular sequence of bytes is possible with functions+-- 'toProtectionPassword' and 'fromProtectionPassword'.+--+-- Beware: the 'fromString' implementation correctly handles multi-byte+-- characters, so here is not equivalent to the 'ByteString' counterpart.+data ProtectionPassword = NullPassword | PasswordUTF8 ByteString+ deriving Eq++instance Show ProtectionPassword where+ showsPrec _ NullPassword = showString "emptyNotTerminated"+ showsPrec d (PasswordUTF8 b) = showParen (d > 10) $+ showString "toProtectionPassword " . showsPrec 11 b++instance IsString ProtectionPassword where+ fromString = PasswordUTF8 . B.convert . S.toBytes S.UTF8 . fromString++instance ByteArrayAccess ProtectionPassword where+ length = applyPP 0 B.length+ withByteArray = B.withByteArray . fromProtectionPassword++applyPP :: a -> (ByteString -> a) -> ProtectionPassword -> a+applyPP d _ NullPassword = d+applyPP _ f (PasswordUTF8 b) = f b++-- | A value denoting an empty password, but having a special encoding when+-- deriving a symmetric key on some systems, like the certificate export+-- wizard on Windows.+--+-- This value is different from @'toProtectionPassword' ""@ and can be tried+-- when decrypting content with a password known to be empty.+emptyNotTerminated :: ProtectionPassword+emptyNotTerminated = NullPassword++-- | Extract the UTF-8 bytes in a password value.+fromProtectionPassword :: ProtectionPassword -> ByteString+fromProtectionPassword = applyPP B.empty id++-- | Build a password value from a sequence of UTF-8 bytes.+--+-- When the password is empty, the special value 'emptyNotTerminated' may+-- be tried as well.+toProtectionPassword :: ByteString -> ProtectionPassword+toProtectionPassword = PasswordUTF8++toProtectionPasswords :: ByteString -> [ProtectionPassword]+toProtectionPasswords bs+ | B.null bs = [PasswordUTF8 B.empty, NullPassword]+ | otherwise = [PasswordUTF8 bs]++-- | Secret key.+type Key = B.ScrubbedBytes++-- | PBES1 parameters.+data PBEParameter = PBEParameter+ { pbeSalt :: Salt -- ^ 8-octet salt value+ , pbeIterationCount :: Int -- ^ Iteration count+ }+ deriving (Show,Eq)++instance ASN1Elem e => ProduceASN1Object e PBEParameter where+ asn1s PBEParameter{..} =+ let salt = gOctetString pbeSalt+ iters = gIntVal (toInteger pbeIterationCount)+ in asn1Container Sequence (salt . iters)++instance Monoid e => ParseASN1Object e PBEParameter where+ parse = onNextContainer Sequence $ do+ OctetString salt <- getNext+ IntVal iters <- getNext+ return PBEParameter { pbeSalt = salt+ , pbeIterationCount = fromInteger iters }++cbcWith :: (BlockCipher cipher, ByteArrayAccess iv)+ => ContentEncryptionCipher cipher -> iv -> ContentEncryptionParams+cbcWith cipher iv = ParamsCBC cipher getIV+ where+ getIV = fromMaybe (error "PKCS5: bad initialization vector") (makeIV iv)++rc2cbcWith :: ByteArrayAccess iv => Int -> iv -> ContentEncryptionParams+rc2cbcWith len iv = ParamsCBCRC2 len getIV+ where+ getIV = fromMaybe (error "PKCS5: bad RC2 initialization vector") (makeIV iv)++-- | RC4 encryption or decryption.+rc4Combine :: (ByteArrayAccess key, ByteArray ba) => key -> ba -> Either StoreError ba+rc4Combine key = Right . snd . RC4.combine (RC4.initialize key)++-- | Conversion to UCS2 from UTF-8, ignoring non-BMP bits.+toUCS2 :: ByteArray bucs2 => ProtectionPassword -> Maybe bucs2+toUCS2 NullPassword = Just B.empty+toUCS2 (PasswordUTF8 pwdUTF8)+ | B.null r = Just pwdUCS2+ | otherwise = Nothing+ where+ (p, _, r) = S.fromBytes S.UTF8 $ B.snoc (B.convert pwdUTF8) 0+ pwdBlock = fromList $ map ucs2 $ toList p :: Block (BE Word16)+ pwdUCS2 = B.convert pwdBlock++ ucs2 :: Char -> BE Word16+ ucs2 = toBE . toEnum . fromEnum+++-- PBES1, RFC 8018 section 6.1.2++-- | Apply PBKDF1 on the specified password and run an encryption or decryption+-- function on some input using derived key and IV.+pkcs5 :: (Hash.HashAlgorithm hash, BlockCipher cipher)+ => (StoreError -> result)+ -> (Key -> ContentEncryptionParams -> ByteString -> result)+ -> DigestProxy hash+ -> ContentEncryptionCipher cipher+ -> PBEParameter+ -> ByteString+ -> ProtectionPassword+ -> result+pkcs5 failure encdec hashAlg cec pbeParam bs pwd+ | proxyBlockSize cec /= 8 = failure (InvalidParameter "Invalid cipher block size")+ | otherwise =+ case pbkdf1 hashAlg (fromProtectionPassword pwd) pbeParam 16 of+ Left err -> failure err+ Right dk ->+ let (key, iv) = B.splitAt 8 (dk :: Key)+ in encdec key (cbcWith cec iv) bs+++-- PBKDF1, RFC 8018 section 5.1++pbkdf1 :: (Hash.HashAlgorithm hash, ByteArrayAccess password, ByteArray out)+ => DigestProxy hash+ -> password+ -> PBEParameter+ -> Int+ -> Either StoreError out+pbkdf1 hashAlg pwd PBEParameter{..} dkLen+ | dkLen > B.length t1 = Left (InvalidParameter "Derived key too long")+ | otherwise = Right (B.convert $ B.takeView tc dkLen)+ where+ a = hashFromProxy hashAlg+ t1 = Hash.hashFinalize (Hash.hashUpdate (Hash.hashUpdate (Hash.hashInitWith a) pwd) pbeSalt)+ tc = iterate (Hash.hashWith a) t1 !! pred pbeIterationCount+++-- PKCS#12 encryption, RFC 7292 appendix B.2++-- | Apply PKCS #12 derivation on the specified password and run an encryption+-- or decryption function on some input using derived key and IV.+pkcs12 :: (Hash.HashAlgorithm hash, BlockCipher cipher)+ => (StoreError -> result)+ -> (Key -> ContentEncryptionParams -> ByteString -> result)+ -> DigestProxy hash+ -> ContentEncryptionCipher cipher+ -> PBEParameter+ -> ByteString+ -> ProtectionPassword+ -> result+pkcs12 failure encdec hashAlg cec pbeParam bs pwdUTF8 =+ case toUCS2 pwdUTF8 of+ Nothing -> failure passwordNotUTF8+ Just pwdUCS2 ->+ let ivLen = proxyBlockSize cec+ iv = pkcs12Derive hashAlg pbeParam 2 pwdUCS2 ivLen :: B.Bytes+ eScheme = cbcWith cec iv+ keyLen = getMaximumKeySize eScheme+ key = pkcs12Derive hashAlg pbeParam 1 pwdUCS2 keyLen :: Key+ in encdec key eScheme bs++-- | Apply PKCS #12 derivation on the specified password and run an encryption+-- or decryption function on some input using derived key and IV. This variant+-- uses an RC2 cipher with the EKL specified (effective key length).+pkcs12rc2 :: Hash.HashAlgorithm hash+ => (StoreError -> result)+ -> (Key -> ContentEncryptionParams -> ByteString -> result)+ -> DigestProxy hash+ -> Int+ -> PBEParameter+ -> ByteString+ -> ProtectionPassword+ -> result+pkcs12rc2 failure encdec hashAlg len pbeParam bs pwdUTF8 =+ case toUCS2 pwdUTF8 of+ Nothing -> failure passwordNotUTF8+ Just pwdUCS2 ->+ let ivLen = 8+ iv = pkcs12Derive hashAlg pbeParam 2 pwdUCS2 ivLen :: B.Bytes+ eScheme = rc2cbcWith len iv+ keyLen = getMaximumKeySize eScheme+ key = pkcs12Derive hashAlg pbeParam 1 pwdUCS2 keyLen :: Key+ in encdec key eScheme bs++-- | Apply PKCS #12 derivation on the specified password and run an encryption+-- or decryption function on some input using derived key. This variant does+-- not derive any IV and is required for RC4.+pkcs12stream :: Hash.HashAlgorithm hash+ => (StoreError -> result)+ -> (Key -> ByteString -> result)+ -> DigestProxy hash+ -> Int+ -> PBEParameter+ -> ByteString+ -> ProtectionPassword+ -> result+pkcs12stream failure encdec hashAlg keyLen pbeParam bs pwdUTF8 =+ case toUCS2 pwdUTF8 of+ Nothing -> failure passwordNotUTF8+ Just pwdUCS2 ->+ let key = pkcs12Derive hashAlg pbeParam 1 pwdUCS2 keyLen :: Key+ in encdec key bs++-- | Apply PKCS #12 derivation on the specified password and run a MAC function+-- on some input using derived key.+pkcs12mac :: Hash.HashAlgorithm hash+ => (StoreError -> result)+ -> (Key -> MACAlgorithm -> ByteString -> result)+ -> DigestProxy hash+ -> PBEParameter+ -> ByteString+ -> ProtectionPassword+ -> result+pkcs12mac failure macFn hashAlg pbeParam bs pwdUTF8 =+ case toUCS2 pwdUTF8 of+ Nothing -> failure passwordNotUTF8+ Just pwdUCS2 ->+ let macAlg = HMAC hashAlg+ keyLen = getMaximumKeySize macAlg+ key = pkcs12Derive hashAlg pbeParam 3 pwdUCS2 keyLen :: Key+ in macFn key macAlg bs++passwordNotUTF8 :: StoreError+passwordNotUTF8 = InvalidPassword "Provided password is not valid UTF-8"++pkcs12Derive :: (Hash.HashAlgorithm hash, ByteArray bout)+ => DigestProxy hash+ -> PBEParameter+ -> Word8+ -> ByteString -- password (UCS2)+ -> Int+ -> bout+pkcs12Derive hashAlg PBEParameter{..} idByte pwdUCS2 n =+ B.take n $ B.concat $ take c $ loop t (s `B.append` p)+ where+ a = hashFromProxy hashAlg+ v = getV (DigestAlgorithm hashAlg)+ u = Hash.hashDigestSize a++ c = (n + u - 1) `div` u+ d = B.replicate v idByte :: B.Bytes+ t = Hash.hashUpdate (Hash.hashInitWith a) d++ p = pwdUCS2 `extendedToMult` v+ s = pbeSalt `extendedToMult` v++ loop :: Hash.HashAlgorithm hash+ => Hash.Context hash -> ByteString -> [Hash.Digest hash]+ loop x i = let z = Hash.hashFinalize (Hash.hashUpdate x i)+ ai = iterate Hash.hash z !! pred pbeIterationCount+ b = ai `extendedTo` v+ j = B.concat $ map (add1 b) (chunks v i)+ in ai : loop x j++getV :: DigestAlgorithm -> Int+getV (DigestAlgorithm MD2) = 64+getV (DigestAlgorithm MD4) = 64+getV (DigestAlgorithm MD5) = 64+getV (DigestAlgorithm SHA1) = 64+getV (DigestAlgorithm SHA224) = 64+getV (DigestAlgorithm SHA256) = 64+getV (DigestAlgorithm SHA384) = 128+getV (DigestAlgorithm SHA512) = 128+getV t = error ("pkcs12Derive: unsupported hash: " ++ show t)++hashFromProxy :: proxy a -> a+hashFromProxy _ = undefined++-- Split in chunks of size 'n'+chunks :: ByteArray ba => Int -> ba -> [ba]+chunks n bs+ | len > n = let (c, cs) = B.splitAt n bs in c : chunks n cs+ | len > 0 = [bs]+ | otherwise = []+ where+ len = B.length bs++-- Concatenate copies of input 'bs' to create output of length 'n'+-- bytes (the final copy may be truncated)+extendedTo :: (ByteArrayAccess bin, ByteArray bout) => bin -> Int -> bout+bs `extendedTo` n =+ B.allocAndFreeze n $ \pout ->+ B.withByteArray bs $ \pin -> do+ mapM_ (\off -> memCopy (pout `plusPtr` off) pin len)+ (enumFromThenTo 0 len (n - len))+ memCopy (pout `plusPtr` (n - r)) pin r+ where+ len = B.length bs+ r = n `mod` len+{-# NOINLINE extendedTo #-}++-- Concatenate copies of input 'bs' to create output whose length is a+-- multiple of 'n' bytes (the final copy may be truncated). If input+-- is the empty string, so is the output.+extendedToMult :: ByteArray ba => ba -> Int -> ba+bs `extendedToMult` n+ | len > n = bs `B.append` B.take (n - len `mod` n) bs+ | len == n = bs+ | len > 0 = bs `extendedTo` n+ | otherwise = B.empty+ where+ len = B.length bs++-- Add two bytearrays (considered as big-endian integers) and increment the+-- result. Output has size of the first bytearray.+add1 :: ByteString -> ByteString -> ByteString+add1 a b =+ B.allocAndFreeze alen $ \pc ->+ B.withByteArray a $ \pa ->+ B.withByteArray b $ \pb ->+ loop3 pa pb pc alen blen 1+ where+ alen = B.length a+ blen = B.length b++ -- main loop when both 'a' and 'b' have remaining bytes+ loop3 !pa !pb !pc !ma !mb !c+ | ma == 0 = return ()+ | mb == 0 = loop2 pa pc ma c+ | otherwise = do+ let na = pred ma+ nb = pred mb+ ba <- peekElemOff pa na+ bb <- peekElemOff pb nb+ let (cc, bc) = carryAdd3 c ba bb+ pokeElemOff pc na bc+ loop3 pa pb pc na nb cc++ -- when 'b' is smaller and bytes are exhausted we propagate+ -- carry on 'a' alone+ loop2 !pa !pc !ma !c+ | ma == 0 = return ()+ | otherwise = do+ let na = pred ma+ ba <- peekElemOff pa na+ let (cc, bc) = carryAdd2 c ba+ pokeElemOff pc na bc+ loop2 pa pc na cc++split16 :: Word16 -> (Word8, Word8)+split16 x = (fromIntegral (shiftR x 8), fromIntegral x)++carryAdd2 :: Word8 -> Word8 -> (Word8, Word8)+carryAdd2 a b = split16 (fromIntegral a + fromIntegral b)++carryAdd3 :: Word8 -> Word8 -> Word8 -> (Word8, Word8)+carryAdd3 a b c = split16 (fromIntegral a + fromIntegral b + fromIntegral c)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS8.hs view
@@ -0,0 +1,714 @@+-- |+-- Module : Crypto.Store.PKCS8+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Private-Key Information Syntax, aka PKCS #8.+--+-- Presents an API similar to "Data.X509.Memory" and "Data.X509.File" but+-- allows to write private keys and provides support for password-based+-- encryption.+--+-- Functions to read a private key return an object wrapped in the+-- 'OptProtected' data type.+--+-- Functions related to public keys, certificates and CRLs are available from+-- "Crypto.Store.X509".+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+module Crypto.Store.PKCS8+ ( readKeyFile+ , readKeyFileFromMemory+ , pemToKey+ , writeKeyFile+ , writeKeyFileToMemory+ , keyToPEM+ , writeEncryptedKeyFile+ , writeEncryptedKeyFileToMemory+ , encryptKeyToPEM+ -- * Serialization formats+ , PrivateKeyFormat(..)+ , FormattedKey(..)+ -- * Password-based protection+ , ProtectionPassword+ , emptyNotTerminated+ , fromProtectionPassword+ , toProtectionPassword+ , OptProtected(..)+ , recover+ , recoverA+ -- * Reading and writing PEM files+ , readPEMs+ , writePEMs+ ) where++import Control.Applicative+import Control.Monad (void, when)++import Data.ASN1.Types+import Data.ASN1.BinaryEncoding+import Data.ASN1.BitArray+import Data.ASN1.Encoding+import Data.ByteArray (ByteArrayAccess, convert)+import Data.Maybe+import qualified Data.X509 as X509+import qualified Data.ByteString as B+import Crypto.Error+import Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip)+import qualified Crypto.PubKey.Curve25519 as X25519+import qualified Crypto.PubKey.Curve448 as X448+import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA as RSA++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Attribute+import Crypto.Store.CMS.Util+import Crypto.Store.Error+import Crypto.Store.PEM+import Crypto.Store.PKCS5+import Crypto.Store.PKCS8.EC+import Crypto.Store.Util++-- | Data type for objects that are possibly protected with a password.+data OptProtected a = Unprotected a+ -- ^ Value is unprotected+ | Protected (ProtectionPassword -> Either StoreError a)+ -- ^ Value is protected with a password++instance Functor OptProtected where+ fmap f (Unprotected x) = Unprotected (f x)+ fmap f (Protected g) = Protected (fmap f . g)++-- | Try to recover an 'OptProtected' content using the specified password.+recover :: ProtectionPassword -> OptProtected a -> Either StoreError a+recover _ (Unprotected x) = Right x+recover pwd (Protected f) = f pwd++-- | Try to recover an 'OptProtected' content in an applicative context. The+-- applicative password is used if necessary.+--+-- > import qualified Data.ByteString as B+-- > import Crypto.Store.PKCS8+-- >+-- > [encryptedKey] <- readKeyFile "privkey.pem"+-- > let askForPassword = putStr "Please enter password: " >> B.getLine+-- > result <- recoverA (toProtectionPassword <$> askForPassword) encryptedKey+-- > case result of+-- > Left err -> putStrLn $ "Unable to recover key: " ++ show err+-- > Right key -> print key+recoverA :: Applicative f+ => f ProtectionPassword+ -> OptProtected a+ -> f (Either StoreError a)+recoverA _ (Unprotected x) = pure (Right x)+recoverA get (Protected f) = fmap f get+++-- Reading from PEM format++-- | Read private keys from a PEM file.+readKeyFile :: FilePath -> IO [OptProtected X509.PrivKey]+readKeyFile path = accumulate <$> readPEMs path++-- | Read private keys from a bytearray in PEM format.+readKeyFileFromMemory :: B.ByteString -> [OptProtected X509.PrivKey]+readKeyFileFromMemory = either (const []) accumulate . pemParseBS++accumulate :: [PEM] -> [OptProtected X509.PrivKey]+accumulate = catMaybes . foldr (flip pemToKey) []++-- | Read a private key from a 'PEM' element and add it to the accumulator list.+pemToKey :: [Maybe (OptProtected X509.PrivKey)] -> PEM -> [Maybe (OptProtected X509.PrivKey)]+pemToKey acc pem =+ case decodeASN1' BER (pemContent pem) of+ Left _ -> acc+ Right asn1 -> run (getParser $ pemName pem) asn1 : acc++ where+ run p = either (const Nothing) Just . runParseASN1 p++ allTypes = unFormat <$> parse+ rsa = X509.PrivKeyRSA . unFormat <$> parse+ dsa = X509.PrivKeyDSA . DSA.toPrivateKey . unFormat <$> parse+ ecdsa = X509.PrivKeyEC . unFormat <$> parse+ x25519 = X509.PrivKeyX25519 <$> parseModern+ x448 = X509.PrivKeyX448 <$> parseModern+ ed25519 = X509.PrivKeyEd25519 <$> parseModern+ ed448 = X509.PrivKeyEd448 <$> parseModern+ encrypted = inner . decrypt <$> parse++ getParser "PRIVATE KEY" = Unprotected <$> allTypes+ getParser "RSA PRIVATE KEY" = Unprotected <$> rsa+ getParser "DSA PRIVATE KEY" = Unprotected <$> dsa+ getParser "EC PRIVATE KEY" = Unprotected <$> ecdsa+ getParser "X25519 PRIVATE KEY" = Unprotected <$> x25519+ getParser "X448 PRIVATE KEY" = Unprotected <$> x448+ getParser "ED25519 PRIVATE KEY" = Unprotected <$> ed25519+ getParser "ED448 PRIVATE KEY" = Unprotected <$> ed448+ getParser "ENCRYPTED PRIVATE KEY" = Protected <$> encrypted+ getParser _ = empty++ inner decfn pwd = do+ decrypted <- decfn pwd+ asn1 <- mapLeft DecodingError $ decodeASN1' BER decrypted+ case run allTypes asn1 of+ Nothing -> Left (ParseFailure "No key parsed after decryption")+ Just k -> return k+++-- Writing to PEM format++-- | Write unencrypted private keys to a PEM file.+writeKeyFile :: PrivateKeyFormat -> FilePath -> [X509.PrivKey] -> IO ()+writeKeyFile fmt path = writePEMs path . map (keyToPEM fmt)++-- | Write unencrypted private keys to a bytearray in PEM format.+writeKeyFileToMemory :: PrivateKeyFormat -> [X509.PrivKey] -> B.ByteString+writeKeyFileToMemory fmt = pemsWriteBS . map (keyToPEM fmt)++-- | Write a PKCS #8 encrypted private key to a PEM file.+--+-- If multiple keys need to be stored in the same file, use functions+-- 'encryptKeyToPEM' and 'writePEMs'.+--+-- Fresh 'EncryptionScheme' parameters should be generated for each key to+-- encrypt.+writeEncryptedKeyFile :: FilePath+ -> EncryptionScheme -> ProtectionPassword -> X509.PrivKey+ -> IO (Either StoreError ())+writeEncryptedKeyFile path alg pwd privKey =+ let pem = encryptKeyToPEM alg pwd privKey+ in either (return . Left) (fmap Right . writePEMs path . (:[])) pem++-- | Write a PKCS #8 encrypted private key to a bytearray in PEM format.+--+-- If multiple keys need to be stored in the same bytearray, use functions+-- 'encryptKeyToPEM' and 'pemWriteBS' or 'pemWriteLBS'.+--+-- Fresh 'EncryptionScheme' parameters should be generated for each key to+-- encrypt.+writeEncryptedKeyFileToMemory :: EncryptionScheme -> ProtectionPassword+ -> X509.PrivKey -> Either StoreError B.ByteString+writeEncryptedKeyFileToMemory alg pwd privKey =+ pemWriteBS <$> encryptKeyToPEM alg pwd privKey++-- | Generate an unencrypted PEM for a private key.+keyToPEM :: PrivateKeyFormat -> X509.PrivKey -> PEM+keyToPEM TraditionalFormat = keyToTraditionalPEM+keyToPEM PKCS8Format = keyToModernPEM++keyToTraditionalPEM :: X509.PrivKey -> PEM+keyToTraditionalPEM privKey =+ mkPEM (typeTag ++ " PRIVATE KEY") (encodeASN1S asn1)+ where (typeTag, asn1) = traditionalPrivKeyASN1S privKey++traditionalPrivKeyASN1S :: ASN1Elem e => X509.PrivKey -> (String, ASN1Stream e)+traditionalPrivKeyASN1S privKey =+ case privKey of+ X509.PrivKeyRSA k -> ("RSA", traditional k)+ X509.PrivKeyDSA k -> ("DSA", traditional (dsaPrivToPair k))+ X509.PrivKeyEC k -> ("EC", traditional k)+ X509.PrivKeyX25519 k -> ("X25519", tradModern k)+ X509.PrivKeyX448 k -> ("X448", tradModern k)+ X509.PrivKeyEd25519 k -> ("ED25519", tradModern k)+ X509.PrivKeyEd448 k -> ("ED448", tradModern k)+ where+ traditional a = asn1s (Traditional a)+ tradModern a = asn1s (Modern [] a)++keyToModernPEM :: X509.PrivKey -> PEM+keyToModernPEM privKey = mkPEM "PRIVATE KEY" (encodeASN1S asn1)+ where asn1 = modernPrivKeyASN1S [] privKey++modernPrivKeyASN1S :: ASN1Elem e => [Attribute] -> X509.PrivKey -> ASN1Stream e+modernPrivKeyASN1S attrs privKey =+ case privKey of+ X509.PrivKeyRSA k -> modern k+ X509.PrivKeyDSA k -> modern (dsaPrivToPair k)+ X509.PrivKeyEC k -> modern k+ X509.PrivKeyX25519 k -> modern k+ X509.PrivKeyX448 k -> modern k+ X509.PrivKeyEd25519 k -> modern k+ X509.PrivKeyEd448 k -> modern k+ where+ modern a = asn1s (Modern attrs a)++-- | Generate a PKCS #8 encrypted PEM for a private key.+--+-- Fresh 'EncryptionScheme' parameters should be generated for each key to+-- encrypt.+encryptKeyToPEM :: EncryptionScheme -> ProtectionPassword -> X509.PrivKey+ -> Either StoreError PEM+encryptKeyToPEM alg pwd privKey = toPEM <$> encrypt alg pwd bs+ where bs = pemContent (keyToModernPEM privKey)+ toPEM pkcs8 = mkPEM "ENCRYPTED PRIVATE KEY" (encodeASN1Object pkcs8)++mkPEM :: String -> B.ByteString -> PEM+mkPEM name bs = PEM { pemName = name, pemHeader = [], pemContent = bs}+++-- Private key formats: traditional (SSLeay compatible) and modern (PKCS #8)++-- | Private-key serialization format.+--+-- Encryption in traditional format is not supported currently.+data PrivateKeyFormat = TraditionalFormat -- ^ SSLeay compatible+ | PKCS8Format -- ^ PKCS #8+ deriving (Show,Eq)++newtype Traditional a = Traditional { unTraditional :: a }++parseTraditional :: ParseASN1Object e (Traditional a) => ParseASN1 e a+parseTraditional = unTraditional <$> parse++data Modern a = Modern [Attribute] a++instance Functor Modern where+ fmap f (Modern attrs a) = Modern attrs (f a)++parseModern :: ParseASN1Object e (Modern a) => ParseASN1 e a+parseModern = unModern <$> parse+ where unModern (Modern _ a) = a++-- | A key associated with format. Allows to implement 'ASN1Object' instances.+data FormattedKey a = FormattedKey PrivateKeyFormat a+ deriving (Show,Eq)++instance Functor FormattedKey where+ fmap f (FormattedKey fmt a) = FormattedKey fmt (f a)++instance (ProduceASN1Object e (Traditional a), ProduceASN1Object e (Modern a)) => ProduceASN1Object e (FormattedKey a) where+ asn1s (FormattedKey TraditionalFormat k) = asn1s (Traditional k)+ asn1s (FormattedKey PKCS8Format k) = asn1s (Modern [] k)++instance (Monoid e, ParseASN1Object e (Traditional a), ParseASN1Object e (Modern a)) => ParseASN1Object e (FormattedKey a) where+ parse = (modern <$> parseModern) <|> (traditional <$> parseTraditional)+ where+ traditional = FormattedKey TraditionalFormat+ modern = FormattedKey PKCS8Format++unFormat :: FormattedKey a -> a+unFormat (FormattedKey _ a) = a+++-- Private Keys++instance ASN1Object (FormattedKey X509.PrivKey) where+ toASN1 = asn1s+ fromASN1 = runParseASN1State parse++instance ASN1Elem e => ProduceASN1Object e (Traditional X509.PrivKey) where+ asn1s (Traditional privKey) = snd $ traditionalPrivKeyASN1S privKey++instance Monoid e => ParseASN1Object e (Traditional X509.PrivKey) where+ parse = rsa <|> dsa <|> ecdsa+ where+ rsa = Traditional . X509.PrivKeyRSA . unTraditional <$> parse+ dsa = Traditional . X509.PrivKeyDSA . DSA.toPrivateKey . unTraditional <$> parse+ ecdsa = Traditional . X509.PrivKeyEC . unTraditional <$> parse++instance ASN1Elem e => ProduceASN1Object e (Modern X509.PrivKey) where+ asn1s (Modern attrs privKey) = modernPrivKeyASN1S attrs privKey++instance Monoid e => ParseASN1Object e (Modern X509.PrivKey) where+ parse = rsa <|> dsa <|> ecdsa <|> x25519 <|> x448 <|> ed25519 <|> ed448+ where+ rsa = fmap X509.PrivKeyRSA <$> parse+ dsa = fmap (X509.PrivKeyDSA . DSA.toPrivateKey) <$> parse+ ecdsa = fmap X509.PrivKeyEC <$> parse+ x25519 = fmap X509.PrivKeyX25519 <$> parse+ x448 = fmap X509.PrivKeyX448 <$> parse+ ed25519 = fmap X509.PrivKeyEd25519 <$> parse+ ed448 = fmap X509.PrivKeyEd448 <$> parse++skipVersion :: Monoid e => ParseASN1 e ()+skipVersion = do+ IntVal v <- getNext+ when (v /= 0 && v /= 1) $+ throwParseError ("PKCS8: parsed invalid version: " ++ show v)++skipPublicKey :: Monoid e => ParseASN1 e ()+skipPublicKey = void (fmap Just parseTaggedPrimitive <|> return Nothing)+ where parseTaggedPrimitive = do { Other _ 1 bs <- getNext; return bs }++parseAttrKeys :: Monoid e => ParseASN1 e ([Attribute], B.ByteString)+parseAttrKeys = do+ OctetString bs <- getNext+ attrs <- parseAttributes (Container Context 0)+ skipPublicKey+ return (attrs, bs)+++-- RSA++instance ASN1Object (FormattedKey RSA.PrivateKey) where+ toASN1 = asn1s+ fromASN1 = runParseASN1State parse++instance ASN1Elem e => ProduceASN1Object e (Traditional RSA.PrivateKey) where+ asn1s (Traditional privKey) =+ asn1Container Sequence (v . n . e . d . p1 . p2 . pexp1 . pexp2 . pcoef)+ where+ pubKey = RSA.private_pub privKey++ v = gIntVal 0+ n = gIntVal (RSA.public_n pubKey)+ e = gIntVal (RSA.public_e pubKey)+ d = gIntVal (RSA.private_d privKey)+ p1 = gIntVal (RSA.private_p privKey)+ p2 = gIntVal (RSA.private_q privKey)+ pexp1 = gIntVal (RSA.private_dP privKey)+ pexp2 = gIntVal (RSA.private_dQ privKey)+ pcoef = gIntVal (RSA.private_qinv privKey)++instance Monoid e => ParseASN1Object e (Traditional RSA.PrivateKey) where+ parse = onNextContainer Sequence $ do+ IntVal 0 <- getNext+ IntVal n <- getNext+ IntVal e <- getNext+ IntVal d <- getNext+ IntVal p1 <- getNext+ IntVal p2 <- getNext+ IntVal pexp1 <- getNext+ IntVal pexp2 <- getNext+ IntVal pcoef <- getNext+ let pubKey = RSA.PublicKey { RSA.public_size = numBytes n+ , RSA.public_n = n+ , RSA.public_e = e+ }+ privKey = RSA.PrivateKey { RSA.private_pub = pubKey+ , RSA.private_d = d+ , RSA.private_p = p1+ , RSA.private_q = p2+ , RSA.private_dP = pexp1+ , RSA.private_dQ = pexp2+ , RSA.private_qinv = pcoef+ }+ return (Traditional privKey)++instance ASN1Elem e => ProduceASN1Object e (Modern RSA.PrivateKey) where+ asn1s (Modern attrs privKey) =+ asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (oid . gNull)+ oid = gOID [1,2,840,113549,1,1,1]+ bs = gOctetString (encodeASN1Object $ Traditional privKey)+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern RSA.PrivateKey) where+ parse = onNextContainer Sequence $ do+ skipVersion+ Null <- onNextContainer Sequence $ do+ OID [1,2,840,113549,1,1,1] <- getNext+ getNext+ (attrs, bs) <- parseAttrKeys+ let inner = decodeASN1' BER bs+ strError = Left . ("PKCS8: error decoding inner RSA: " ++) . show+ case either strError (runParseASN1 parseTraditional) inner of+ Left err -> throwParseError ("PKCS8: error parsing inner RSA: " ++ err)+ Right privKey -> return (Modern attrs privKey)+++-- DSA++instance ASN1Object (FormattedKey DSA.KeyPair) where+ toASN1 = asn1s+ fromASN1 = runParseASN1State parse++instance ASN1Elem e => ProduceASN1Object e (Traditional DSA.KeyPair) where+ asn1s (Traditional (DSA.KeyPair params pub priv)) =+ asn1Container Sequence (v . pqgASN1S params . pub' . priv')+ where+ v = gIntVal 0+ pub' = gIntVal pub+ priv' = gIntVal priv++instance Monoid e => ParseASN1Object e (Traditional DSA.KeyPair) where+ parse = onNextContainer Sequence $ do+ IntVal 0 <- getNext+ params <- parsePQG+ IntVal pub <- getNext+ IntVal priv <- getNext+ return (Traditional $ DSA.KeyPair params pub priv)++instance ASN1Elem e => ProduceASN1Object e (Modern DSA.KeyPair) where+ asn1s (Modern attrs (DSA.KeyPair params _ priv)) =+ asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (oid . pr)+ oid = gOID [1,2,840,10040,4,1]+ pr = asn1Container Sequence (pqgASN1S params)+ bs = gOctetString (encodeASN1S $ gIntVal priv)+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern DSA.KeyPair) where+ parse = onNextContainer Sequence $ do+ skipVersion+ params <- onNextContainer Sequence $ do+ OID [1,2,840,10040,4,1] <- getNext+ onNextContainer Sequence parsePQG+ (attrs, bs) <- parseAttrKeys+ case decodeASN1' BER bs of+ Right [IntVal priv] ->+ let pub = DSA.calculatePublic params priv+ in return (Modern attrs $ DSA.KeyPair params pub priv)+ Right _ -> throwParseError "PKCS8: invalid format when parsing inner DSA"+ Left e -> throwParseError ("PKCS8: error parsing inner DSA: " ++ show e)++pqgASN1S :: ASN1Elem e => DSA.Params -> ASN1Stream e+pqgASN1S params = p . q . g+ where p = gIntVal (DSA.params_p params)+ q = gIntVal (DSA.params_q params)+ g = gIntVal (DSA.params_g params)++parsePQG :: Monoid e => ParseASN1 e DSA.Params+parsePQG = do+ IntVal p <- getNext+ IntVal q <- getNext+ IntVal g <- getNext+ return DSA.Params { DSA.params_p = p+ , DSA.params_q = q+ , DSA.params_g = g+ }++dsaPrivToPair :: DSA.PrivateKey -> DSA.KeyPair+dsaPrivToPair k = DSA.KeyPair params pub x+ where pub = DSA.calculatePublic params x+ params = DSA.private_params k+ x = DSA.private_x k+++-- ECDSA++instance ASN1Object (FormattedKey X509.PrivKeyEC) where+ toASN1 = asn1s+ fromASN1 = runParseASN1State parse++instance ASN1Elem e => ProduceASN1Object e (Traditional X509.PrivKeyEC) where+ asn1s = innerEcdsaASN1S True . unTraditional++instance Monoid e => ParseASN1Object e (Traditional X509.PrivKeyEC) where+ parse = Traditional <$> parseInnerEcdsa Nothing++instance ASN1Elem e => ProduceASN1Object e (Modern X509.PrivKeyEC) where+ asn1s (Modern attrs privKey) = asn1Container Sequence (v . f . bs . att)+ where+ v = gIntVal 0+ f = asn1Container Sequence (oid . curveFnASN1S privKey)+ oid = gOID [1,2,840,10045,2,1]+ bs = gOctetString (encodeASN1S inner)+ inner = innerEcdsaASN1S False privKey+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern X509.PrivKeyEC) where+ parse = onNextContainer Sequence $ do+ skipVersion+ f <- onNextContainer Sequence $ do+ OID [1,2,840,10045,2,1] <- getNext+ parseCurveFn+ (attrs, bs) <- parseAttrKeys+ let inner = decodeASN1' BER bs+ strError = Left . ("PKCS8: error decoding inner EC: " ++) . show+ case either strError (runParseASN1 $ parseInnerEcdsa $ Just f) inner of+ Left err -> throwParseError ("PKCS8: error parsing inner EC: " ++ err)+ Right privKey -> return (Modern attrs privKey)++innerEcdsaASN1S :: ASN1Elem e => Bool -> X509.PrivKeyEC -> ASN1Stream e+innerEcdsaASN1S addC k+ | addC = asn1Container Sequence (v . ds . c0 . c1)+ | otherwise = asn1Container Sequence (v . ds . c1)+ where+ curve = fromMaybe (error "PKCS8: invalid EC parameters") (ecPrivKeyCurve k)+ bytes = curveOrderBytes curve++ v = gIntVal 1+ ds = gOctetString (i2ospOf_ bytes (X509.privkeyEC_priv k))+ c0 = asn1Container (Container Context 0) (curveFnASN1S k)+ c1 = asn1Container (Container Context 1) pub++ pub = gBitString (toBitArray sp 0)+ X509.SerializedPoint sp = getSerializedPoint curve (X509.privkeyEC_priv k)++parseInnerEcdsa :: Monoid e+ => Maybe (ECDSA.PrivateNumber -> X509.PrivKeyEC)+ -> ParseASN1 e X509.PrivKeyEC+parseInnerEcdsa fn = onNextContainer Sequence $ do+ IntVal 1 <- getNext+ OctetString ds <- getNext+ let d = os2ip ds+ m <- onNextContainerMaybe (Container Context 0) parseCurveFn+ _ <- onNextContainerMaybe (Container Context 1) parsePK+ case fn <|> m of+ Nothing -> throwParseError "PKCS8: no curve found in EC private key"+ Just getKey -> return (getKey d)+ where+ parsePK = do { BitString bs <- getNext; return bs }++curveFnASN1S :: ASN1Elem e => X509.PrivKeyEC -> ASN1Stream e+curveFnASN1S X509.PrivKeyEC_Named{..} = gOID (curveNameOID privkeyEC_name)+curveFnASN1S X509.PrivKeyEC_Prime{..} =+ asn1Container Sequence (v . prime . abSeed . gen . o . c)+ where+ X509.SerializedPoint generator = privkeyEC_generator+ bytes = numBytes privkeyEC_prime++ v = gIntVal 1++ prime = asn1Container Sequence (oid . p)+ oid = gOID [1,2,840,10045,1,1]+ p = gIntVal privkeyEC_prime++ abSeed = asn1Container Sequence (a . b . seed)+ a = gOctetString (i2ospOf_ bytes privkeyEC_a)+ b = gOctetString (i2ospOf_ bytes privkeyEC_b)+ seed = if privkeyEC_seed > 0+ then gBitString (toBitArray (i2osp privkeyEC_seed) 0)+ else id++ gen = gOctetString generator+ o = gIntVal privkeyEC_order+ c = gIntVal privkeyEC_cofactor++parseCurveFn :: Monoid e => ParseASN1 e (ECDSA.PrivateNumber -> X509.PrivKeyEC)+parseCurveFn = parseNamedCurve <|> parsePrimeCurve+ where+ parseNamedCurve = do+ OID oid <- getNext+ case lookupCurveNameByOID oid of+ Just name -> return $ \d ->+ X509.PrivKeyEC_Named+ { X509.privkeyEC_name = name+ , X509.privkeyEC_priv = d+ }+ Nothing -> throwParseError ("PKCS8: unknown EC curve with OID " ++ show oid)++ parsePrimeCurve =+ onNextContainer Sequence $ do+ IntVal 1 <- getNext+ prime <- onNextContainer Sequence $ do+ OID [1,2,840,10045,1,1] <- getNext+ IntVal prime <- getNext+ return prime+ (a, b, seed) <- onNextContainer Sequence $ do+ OctetString a <- getNext+ OctetString b <- getNext+ seed <- parseOptionalSeed+ return (a, b, seed)+ OctetString generator <- getNext+ IntVal order <- getNext+ IntVal cofactor <- getNext+ return $ \d ->+ X509.PrivKeyEC_Prime+ { X509.privkeyEC_priv = d+ , X509.privkeyEC_a = os2ip a+ , X509.privkeyEC_b = os2ip b+ , X509.privkeyEC_prime = prime+ , X509.privkeyEC_generator = X509.SerializedPoint generator+ , X509.privkeyEC_order = order+ , X509.privkeyEC_cofactor = cofactor+ , X509.privkeyEC_seed = seed+ }++ parseOptionalSeed = do+ seedAvail <- hasNext+ if seedAvail+ then do BitString seed <- getNext+ return (os2ip $ bitArrayGetData seed)+ else return 0+++-- X25519, X448, Ed25519, Ed448++instance ASN1Elem e => ProduceASN1Object e (Modern X25519.SecretKey) where+ asn1s (Modern attrs privKey) = asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (gOID [1,3,101,110])+ bs = innerEddsaASN1S privKey+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern X25519.SecretKey) where+ parse = onNextContainer Sequence $ do+ skipVersion+ onNextContainer Sequence $ do { OID [1,3,101,110] <- getNext; return () }+ (attrs, bs) <- parseAttrKeys+ Modern attrs <$> parseInnerEddsa "X25519" X25519.secretKey bs++instance ASN1Elem e => ProduceASN1Object e (Modern X448.SecretKey) where+ asn1s (Modern attrs privKey) = asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (gOID [1,3,101,111])+ bs = innerEddsaASN1S privKey+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern X448.SecretKey) where+ parse = onNextContainer Sequence $ do+ skipVersion+ onNextContainer Sequence $ do { OID [1,3,101,111] <- getNext; return () }+ (attrs, bs) <- parseAttrKeys+ Modern attrs <$> parseInnerEddsa "X448" X448.secretKey bs++instance ASN1Elem e => ProduceASN1Object e (Modern Ed25519.SecretKey) where+ asn1s (Modern attrs privKey) = asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (gOID [1,3,101,112])+ bs = innerEddsaASN1S privKey+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern Ed25519.SecretKey) where+ parse = onNextContainer Sequence $ do+ skipVersion+ onNextContainer Sequence $ do { OID [1,3,101,112] <- getNext; return () }+ (attrs, bs) <- parseAttrKeys+ Modern attrs <$> parseInnerEddsa "Ed25519" Ed25519.secretKey bs++instance ASN1Elem e => ProduceASN1Object e (Modern Ed448.SecretKey) where+ asn1s (Modern attrs privKey) = asn1Container Sequence (v . alg . bs . att)+ where+ v = gIntVal 0+ alg = asn1Container Sequence (gOID [1,3,101,113])+ bs = innerEddsaASN1S privKey+ att = attributesASN1S (Container Context 0) attrs++instance Monoid e => ParseASN1Object e (Modern Ed448.SecretKey) where+ parse = onNextContainer Sequence $ do+ skipVersion+ onNextContainer Sequence $ do { OID [1,3,101,113] <- getNext; return () }+ (attrs, bs) <- parseAttrKeys+ Modern attrs <$> parseInnerEddsa "Ed448" Ed448.secretKey bs++innerEddsaASN1S :: (ASN1Elem e, ByteArrayAccess key) => key -> ASN1Stream e+innerEddsaASN1S key = gOctetString (encodeASN1S inner)+ where inner = gOctetString (convert key)++parseInnerEddsa :: Monoid e+ => String+ -> (B.ByteString -> CryptoFailable key)+ -> B.ByteString+ -> ParseASN1 e key+parseInnerEddsa name buildKey input =+ case either strError (runParseASN1 parser) (decodeASN1' BER input) of+ Left err -> throwParseError ("PKCS8: error parsing inner " ++ name ++ ": " ++ err)+ Right privKey -> return privKey+ where+ innerMsg = "PKCS8: error decoding inner " ++ name ++ ": "+ strError = Left . (innerMsg ++) . show+ parser = do+ OctetString bs <- getNext+ case buildKey bs of+ CryptoPassed privKey -> return privKey+ CryptoFailed _ ->+ throwParseError ("PKCS8: parsed invalid " ++ name ++ " secret key")
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/PKCS8/EC.hs view
@@ -0,0 +1,95 @@+-- |+-- Module : Crypto.Store.PKCS8.EC+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Additional EC utilities.+module Crypto.Store.PKCS8.EC+ ( numBytes+ , curveSizeBytes+ , curveOrderBytes+ , curveNameOID+ , getSerializedPoint+ , module Data.X509.EC+ ) where++import Data.ASN1.OID+import qualified Data.ByteString as B+import Data.Maybe (fromMaybe)++import Data.X509+import Data.X509.EC++import Crypto.Number.Basic (numBits, numBytes)+import Crypto.Number.Serialize (i2ospOf_)+import Crypto.PubKey.ECC.Prim+import Crypto.PubKey.ECC.Types++import Crypto.Store.CMS.Util++-- | Number of bytes necessary to serialize n bits.+bitsToBytes :: Int -> Int+bitsToBytes n = (n + 7) `div` 8++-- | Number of bytes to serialize a field element.+curveSizeBytes :: Curve -> Int+curveSizeBytes = bitsToBytes . curveSizeBits++-- | Number of bytes to serialize a scalar.+curveOrderBytes :: Curve -> Int+curveOrderBytes = bitsToBytes . numBits . ecc_n . common_curve++-- | Transform a private scalar to a point in uncompressed format.+getSerializedPoint :: Curve -> PrivateNumber -> SerializedPoint+getSerializedPoint curve d = SerializedPoint (serializePoint pt)+ where+ pt = pointBaseMul curve d+ bs = i2ospOf_ (curveSizeBytes curve)++ serializePoint PointO = B.singleton 0+ serializePoint (Point x y) = B.cons 4 (B.append (bs x) (bs y))++-- | Return the OID associated to a curve name.+curveNameOID :: CurveName -> OID+curveNameOID name =+ fromMaybe (error $ "PKCS8: OID unknown for EC curve " ++ show name)+ (lookupOID curvesOIDTable name)++curvesOIDTable :: OIDTable CurveName+curvesOIDTable =+ [ (SEC_p112r1, [1,3,132,0,6])+ , (SEC_p112r2, [1,3,132,0,7])+ , (SEC_p128r1, [1,3,132,0,28])+ , (SEC_p128r2, [1,3,132,0,29])+ , (SEC_p160k1, [1,3,132,0,9])+ , (SEC_p160r1, [1,3,132,0,8])+ , (SEC_p160r2, [1,3,132,0,30])+ , (SEC_p192k1, [1,3,132,0,31])+ , (SEC_p192r1, [1,2,840,10045,3,1,1])+ , (SEC_p224k1, [1,3,132,0,32])+ , (SEC_p224r1, [1,3,132,0,33])+ , (SEC_p256k1, [1,3,132,0,10])+ , (SEC_p256r1, [1,2,840,10045,3,1,7])+ , (SEC_p384r1, [1,3,132,0,34])+ , (SEC_p521r1, [1,3,132,0,35])+ , (SEC_t113r1, [1,3,132,0,4])+ , (SEC_t113r2, [1,3,132,0,5])+ , (SEC_t131r1, [1,3,132,0,22])+ , (SEC_t131r2, [1,3,132,0,23])+ , (SEC_t163k1, [1,3,132,0,1])+ , (SEC_t163r1, [1,3,132,0,2])+ , (SEC_t163r2, [1,3,132,0,15])+ , (SEC_t193r1, [1,3,132,0,24])+ , (SEC_t193r2, [1,3,132,0,25])+ , (SEC_t233k1, [1,3,132,0,26])+ , (SEC_t233r1, [1,3,132,0,27])+ , (SEC_t239k1, [1,3,132,0,3])+ , (SEC_t283k1, [1,3,132,0,16])+ , (SEC_t283r1, [1,3,132,0,17])+ , (SEC_t409k1, [1,3,132,0,36])+ , (SEC_t409r1, [1,3,132,0,37])+ , (SEC_t571k1, [1,3,132,0,38])+ , (SEC_t571r1, [1,3,132,0,39])+ ]
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/Util.hs view
@@ -0,0 +1,72 @@+-- |+-- Module : Crypto.Store.Util+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+module Crypto.Store.Util+ ( (&&!)+ , reverseBytes+ , constAllEq+ , mapLeft+ , mapAsWord64LE+ ) where++import Data.Bits+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as B+import Data.List+import Data.Memory.Endian+import Data.Word++import Foreign.Ptr (plusPtr)+import Foreign.Storable++import GHC.Exts++-- | This is a strict version of &&.+(&&!) :: Bool -> Bool -> Bool+(&&!) x y = isTrue# (andI# (getTag# x) (getTag# y))+ where getTag# !z = dataToTag# z+infixr 3 &&!++-- | Reverse a bytearray.+reverseBytes :: ByteArray ba => ba -> ba+#if MIN_VERSION_memory(0,14,18)+reverseBytes = B.reverse+#else+reverseBytes = B.pack . reverse . B.unpack+#endif++-- | Test if all bytes in a bytearray are equal to the value specified. Runs in+-- constant time.+constAllEq :: ByteArrayAccess ba => Word8 -> ba -> Bool+constAllEq b = (== 0) . foldl' fn 0 . B.unpack+ where fn acc x = acc .|. xor b x++-- | Map over the left value.+mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f (Left a) = Left (f a)+mapLeft _ (Right c) = Right c++-- | Same as 'Data.ByteArray.Mapping.mapAsWord64' but with little-endian words.+mapAsWord64LE :: ByteArray bs => (Word64 -> Word64) -> bs -> bs+mapAsWord64LE f bs =+ B.allocAndFreeze len $ \dst ->+ B.withByteArray bs $ \src ->+ loop (len `div` 8) dst src+ where+ len = B.length bs++ loop :: Int -> Ptr (LE Word64) -> Ptr (LE Word64) -> IO ()+ loop 0 _ _ = return ()+ loop i d s = do+ w <- peek s+ let r = f (fromLE w)+ poke d (toLE r)+ loop (i - 1) (d `plusPtr` 8) (s `plusPtr` 8)
+ vendor/cryptostore-0.3.0.1/src/Crypto/Store/X509.hs view
@@ -0,0 +1,175 @@+-- |+-- Module : Crypto.Store.X509+-- License : BSD-style+-- Maintainer : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability : experimental+-- Portability : unknown+--+-- Public keys, certificates and CRLs.+--+-- Presents an API similar to "Data.X509.Memory" and "Data.X509.File" but+-- provides support for public-key files and allows to write objects.+--+-- Functions related to private keys are available from "Crypto.Store.PKCS8".+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Crypto.Store.X509+ ( SignedObject()+ -- * Public keys+ , readPubKeyFile+ , readPubKeyFileFromMemory+ , pemToPubKey+ , writePubKeyFile+ , writePubKeyFileToMemory+ , pubKeyToPEM+ -- * Signed objects+ , readSignedObject+ , readSignedObjectFromMemory+ , writeSignedObject+ , writeSignedObjectToMemory+ -- * Reading and writing PEM files+ , readPEMs+ , writePEMs+ ) where++import Data.ASN1.Types+import Data.ASN1.BinaryEncoding+import Data.ASN1.Encoding+import Data.Maybe+import Data.Proxy+import qualified Data.X509 as X509+import qualified Data.ByteString as B+import Crypto.Number.Basic (numBytes)+import qualified Crypto.PubKey.RSA as RSA++import Crypto.Store.ASN1.Generate+import Crypto.Store.ASN1.Parse+import Crypto.Store.CMS.Util+import Crypto.Store.PEM+++-- | Class of signed objects convertible to PEM.+class (ASN1Object a, Eq a, Show a) => SignedObject a where+ signedObjectName :: proxy a -> String+ otherObjectNames :: proxy a -> [String]++instance SignedObject X509.Certificate where+ signedObjectName _ = "CERTIFICATE"+ otherObjectNames _ = ["X509 CERTIFICATE"]++instance SignedObject X509.CRL where+ signedObjectName _ = "X509 CRL"+ otherObjectNames _ = []++validObjectName :: SignedObject a => proxy a -> String -> Bool+validObjectName prx name =+ name == signedObjectName prx || name `elem` otherObjectNames prx+++-- Reading from PEM format++-- | Read public keys from a PEM file.+readPubKeyFile :: FilePath -> IO [X509.PubKey]+readPubKeyFile path = accumulate <$> readPEMs path++-- | Read public keys from a bytearray in PEM format.+readPubKeyFileFromMemory :: B.ByteString -> [X509.PubKey]+readPubKeyFileFromMemory = either (const []) accumulate . pemParseBS++accumulate :: [PEM] -> [X509.PubKey]+accumulate = catMaybes . foldr (flip pemToPubKey) []++-- | Read a public key from a 'PEM' element and add it to the accumulator list.+pemToPubKey :: [Maybe X509.PubKey] -> PEM -> [Maybe X509.PubKey]+pemToPubKey acc pem =+ case decodeASN1' BER (pemContent pem) of+ Left _ -> acc+ Right asn1 -> run (getParser $ pemName pem) asn1 : acc++ where+ run p asn1 =+ case p asn1 of+ Right (pubKey, []) -> Just pubKey+ _ -> Nothing++ getParser "PUBLIC KEY" = fromASN1+ getParser "RSA PUBLIC KEY" = runParseASN1State rsapkParser+ getParser _ = const (Left undefined)++ rsapkParser = (\(RSAPublicKey pub) -> X509.PubKeyRSA pub) <$> parse++-- | Read signed objects from a PEM file (only one type at a time).+readSignedObject :: SignedObject a => FilePath -> IO [X509.SignedExact a]+readSignedObject path = accumulate' <$> readPEMs path++-- | Read signed objects from a bytearray in PEM format (only one type at a+-- time).+readSignedObjectFromMemory :: SignedObject a+ => B.ByteString+ -> [X509.SignedExact a]+readSignedObjectFromMemory = either (const []) accumulate' . pemParseBS++accumulate' :: forall a. SignedObject a => [PEM] -> [X509.SignedExact a]+accumulate' = foldr pemToSigned []+ where+ prx = Proxy :: Proxy a++ pemToSigned pem acc+ | validObjectName prx (pemName pem) =+ case X509.decodeSignedObject $ pemContent pem of+ Left _ -> acc+ Right obj -> obj : acc+ | otherwise = acc+++-- Writing to PEM format++-- | Write public keys to a PEM file.+writePubKeyFile :: FilePath -> [X509.PubKey] -> IO ()+writePubKeyFile path = writePEMs path . map pubKeyToPEM++-- | Write public keys to a bytearray in PEM format.+writePubKeyFileToMemory :: [X509.PubKey] -> B.ByteString+writePubKeyFileToMemory = pemsWriteBS . map pubKeyToPEM++-- | Generate a PEM for a public key.+pubKeyToPEM :: X509.PubKey -> PEM+pubKeyToPEM pubKey = mkPEM "PUBLIC KEY" (encodeASN1S $ gMany asn1)+ where asn1 = toASN1 pubKey []++-- | Write signed objects to a PEM file.+writeSignedObject :: SignedObject a => FilePath -> [X509.SignedExact a] -> IO ()+writeSignedObject path = writePEMs path . map signedToPEM++-- | Write signed objects to a bytearray in PEM format.+writeSignedObjectToMemory :: SignedObject a => [X509.SignedExact a] -> B.ByteString+writeSignedObjectToMemory = pemsWriteBS . map signedToPEM++signedToPEM :: forall a. SignedObject a => X509.SignedExact a -> PEM+signedToPEM obj = mkPEM (signedObjectName prx) (X509.encodeSignedObject obj)+ where prx = Proxy :: Proxy a++mkPEM :: String -> B.ByteString -> PEM+mkPEM name bs = PEM { pemName = name, pemHeader = [], pemContent = bs}+++-- RSA public keys++newtype RSAPublicKey = RSAPublicKey RSA.PublicKey++instance ASN1Elem e => ProduceASN1Object e RSAPublicKey where+ asn1s (RSAPublicKey pub) = asn1Container Sequence (n . e)+ where+ n = gIntVal (RSA.public_n pub)+ e = gIntVal (RSA.public_e pub)++instance Monoid e => ParseASN1Object e RSAPublicKey where+ parse = onNextContainer Sequence $ do+ IntVal modulus <- getNext+ IntVal pubexp <- getNext+ let pub = RSA.PublicKey { RSA.public_size = numBytes modulus+ , RSA.public_n = modulus+ , RSA.public_e = pubexp+ }+ return (RSAPublicKey pub)