merging sqlite and bs branches

Since the sqlite branch uses blobs extensively, there are some
performance benefits, ByteStrings now get stored and retrieved w/o
conversion in some cases like in Database.Export.
This commit is contained in:
Joey Hess 2019-12-06 15:17:54 -04:00
commit 2f9a80d803
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
266 changed files with 2860 additions and 1325 deletions

View file

@ -5,6 +5,8 @@
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Applicative (
(<$$>),
) where

21
Utility/Attoparsec.hs Normal file
View file

@ -0,0 +1,21 @@
{- attoparsec utility functions
-
- Copyright 2019 Joey Hess <id@joeyh.name>
- Copyright 2007-2015 Bryan O'Sullivan
-
- License: BSD-3-clause
-}
module Utility.Attoparsec where
import qualified Data.Attoparsec.ByteString as A
import qualified Data.ByteString as B
-- | Parse and decode an unsigned octal number.
--
-- This parser does not accept a leading @\"0o\"@ string.
octal :: Integral a => A.Parser a
octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit
where
isOctDigit w = w >= 48 && w <= 55
step a w = a * 8 + fromIntegral (w - 48)

View file

@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.FileSize (
FileSize,
@ -32,7 +33,10 @@ getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)
getFileSize f = bracket (openFile f ReadMode) hClose hFileSize
#endif
{- Gets the size of the file, when its FileStatus is already known. -}
{- Gets the size of the file, when its FileStatus is already known.
-
- On windows, uses getFileSize. Otherwise, the FileStatus contains the
- size, so this does not do any work. -}
getFileSize' :: FilePath -> FileStatus -> IO FileSize
#ifndef mingw32_HOST_OS
getFileSize' _ s = return $ fromIntegral $ fileSize s

View file

@ -24,6 +24,7 @@ module Utility.Hash (
blake2b_512,
blake2bp_512,
md5,
md5s,
prop_hashes_stable,
Mac(..),
calcMac,
@ -106,6 +107,9 @@ blake2bp_512 = hashlazy
md5 :: L.ByteString -> Digest MD5
md5 = hashlazy
md5s :: S.ByteString -> Digest MD5
md5s = hash
{- Check that all the hashes continue to hash the same. -}
prop_hashes_stable :: Bool
prop_hashes_stable = all (\(hasher, result) -> hasher foo == result)

View file

@ -23,6 +23,7 @@ module Utility.InodeCache (
readInodeCache,
showInodeCache,
genInodeCache,
genInodeCache',
toInodeCache,
InodeCacheKey,
@ -46,6 +47,7 @@ module Utility.InodeCache (
import Common
import Utility.TimeStamp
import Utility.QuickCheck
import qualified Utility.RawFilePath as R
import System.PosixCompat.Types
import Data.Time.Clock.POSIX
@ -187,6 +189,10 @@ genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache f delta = catchDefaultIO Nothing $
toInodeCache delta f =<< getFileStatus f
genInodeCache' :: RawFilePath -> TSDelta -> IO (Maybe InodeCache)
genInodeCache' f delta = catchDefaultIO Nothing $
toInodeCache delta (fromRawFilePath f) =<< R.getFileStatus f
toInodeCache :: TSDelta -> FilePath -> FileStatus -> IO (Maybe InodeCache)
toInodeCache (TSDelta getdelta) f s
| isRegularFile s = do

View file

@ -12,6 +12,7 @@ module Utility.Misc (
readFileStrict,
separate,
firstLine,
firstLine',
segment,
segmentDelim,
massReplace,
@ -28,6 +29,7 @@ import Data.Char
import Data.List
import System.Exit
import Control.Applicative
import qualified Data.ByteString as S
import Prelude
{- A version of hgetContents that is not lazy. Ensures file is
@ -56,6 +58,11 @@ separate c l = unbreak $ break c l
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
firstLine' :: S.ByteString -> S.ByteString
firstLine' = S.takeWhile (/= nl)
where
nl = fromIntegral (ord '\n')
{- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.)
- Segments may be empty. -}

View file

@ -43,6 +43,7 @@ import Utility.Monad
import Utility.UserInfo
import Utility.Directory
import Utility.Split
import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@ -200,20 +201,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- we stop preserving ordering at that point. Presumably a user passing
- that many paths in doesn't care too much about order of the later ones.
-}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest
where
(found, rest) = if length ls < 100
then partition (l `dirContains`) new
else break (\p -> not (l `dirContains` p)) new
then partition inl new
else break (not . inl) new
inl f = fromRawFilePath l `dirContains` fromRawFilePath f
{- This assumes that it's cheaper to call segmentPaths on the result,
- than it would be to run the action separately with each path. In
- the case of git file list commands, that assumption tends to hold.
-}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -}

View file

@ -1,4 +1,11 @@
{- Portability shim around System.Posix.Files.ByteString
-
- On unix, this makes syscalls using RawFilesPaths as efficiently as
- possible.
-
- On Windows, filenames are in unicode, so RawFilePaths have to be
- decoded. So this library will work, but less efficiently than using
- FilePath would.
-
- Copyright 2019 Joey Hess <id@joeyh.name>
-
@ -10,19 +17,20 @@
module Utility.RawFilePath (
RawFilePath,
readSymbolicLink,
getFileStatus,
) where
#ifndef mingw32_HOST_OS
import Utility.FileSystemEncoding (RawFilePath)
import System.Posix.Files.ByteString
import System.Posix.ByteString.FilePath
#else
import qualified Data.ByteString as B
import System.IO.Error
type RawFilePath = B.ByteString
import qualified System.PosixCompat as P
import Utility.FileSystemEncoding
readSymbolicLink :: RawFilePath -> IO RawFilePath
readSymbolicLink _ = ioError $ mkIOError illegalOperationErrorType x Nothing Nothing
where
x = "Utility.RawFilePath.readSymbolicLink: not supported"
readSymbolicLink f = toRawFilePath <$> P.readSymbolicLink (fromRawFilePath f)
getFileStatus :: RawFilePath -> IO FileStatus
getFileStatus = P.getFileStatus . fromRawFilePath
#endif

View file

@ -7,7 +7,23 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.SafeCommand where
module Utility.SafeCommand (
CommandParam(..),
toCommand,
boolSystem,
boolSystem',
boolSystemEnv,
safeSystem,
safeSystem',
safeSystemEnv,
shellWrap,
shellEscape,
shellUnEscape,
segmentXargsOrdered,
segmentXargsUnordered,
prop_isomorphic_shellEscape,
prop_isomorphic_shellEscape_multiword,
) where
import System.Exit
import Utility.Process

View file

@ -7,7 +7,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Utility.Scheduled.QuickCheck where
module Utility.Scheduled.QuickCheck (prop_schedule_roundtrips) where
import Utility.Scheduled
import Utility.QuickCheck

View file

@ -7,7 +7,11 @@
{-# LANGUAGE CPP #-}
module Utility.Shell where
module Utility.Shell (
shellPath,
shebang,
findShellCommand,
) where
import Utility.SafeCommand
#ifdef mingw32_HOST_OS

View file

@ -7,7 +7,12 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Split where
module Utility.Split (
split,
splitc,
replace,
dropFromEnd,
) where
import Data.List (intercalate)
import Data.List.Split (splitOn)
@ -29,6 +34,6 @@ splitc c s = case break (== c) s of
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new = intercalate new . split old
-- | Only traverses the list once while dropping the last n characters.
-- | Only traverses the list once while dropping the last n items.
dropFromEnd :: Int -> [a] -> [a]
dropFromEnd n l = zipWith const l (drop n l)

View file

@ -5,7 +5,24 @@
- License: BSD-2-clause
-}
module Utility.SshConfig where
module Utility.SshConfig (
SshConfig(..),
Comment(..),
SshSetting(..),
Indent,
Host,
Key,
Value,
parseSshConfig,
genSshConfig,
findHostConfigKey,
addToHostConfig,
modifyUserSshConfig,
changeUserSshConfig,
writeSshConfig,
setSshConfigMode,
sshDir,
) where
import Common
import Utility.UserInfo

View file

@ -11,7 +11,17 @@
{-# LANGUAGE BangPatterns #-}
module Utility.TList where
module Utility.TList (
TList,
newTList,
getTList,
setTList,
takeTList,
readTList,
consTList,
snocTList,
appendTList,
) where
import Common

View file

@ -7,7 +7,13 @@
{-# LANGUAGE OverloadedStrings #-}
module Utility.Tense where
module Utility.Tense (
Tense(..),
TenseChunk(..),
TenseText,
renderTense,
tenseWords,
) where
import qualified Data.Text as T
import Data.Text (Text)
@ -52,6 +58,3 @@ tenseWords = TenseText . go []
go c ((Tensed w1 w2):ws) =
go (Tensed (addspace w1) (addspace w2) : c) ws
addspace w = T.append w " "
unTensed :: Text -> TenseText
unTensed t = TenseText [UnTensed t]

View file

@ -5,7 +5,11 @@
- License: BSD-2-clause
-}
module Utility.ThreadLock where
module Utility.ThreadLock (
Lock,
newLock,
withLock,
) where
import Control.Concurrent.MVar

View file

@ -8,7 +8,14 @@
{-# LANGUAGE CPP #-}
module Utility.ThreadScheduler where
module Utility.ThreadScheduler (
Seconds(..),
Microseconds,
runEvery,
threadDelaySeconds,
waitForTermination,
oneSecond,
) where
import Control.Monad
import Control.Concurrent

View file

@ -5,7 +5,11 @@
- License: BSD-2-clause
-}
module Utility.TimeStamp where
module Utility.TimeStamp (
parserPOSIXTime,
parsePOSIXTime,
formatPOSIXTime,
) where
import Utility.Data

View file

@ -8,7 +8,13 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp where
module Utility.Tmp (
Template,
viaTmp,
withTmpFile,
withTmpFileIn,
relatedTemplate,
) where
import System.IO
import System.FilePath

View file

@ -8,7 +8,10 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp.Dir where
module Utility.Tmp.Dir (
withTmpDir,
withTmpDirIn,
) where
import Control.Monad.IfElse
import System.FilePath

View file

@ -7,7 +7,17 @@
{-# LANGUAGE CPP #-}
module Utility.Tor where
module Utility.Tor (
OnionPort,
OnionAddress(..),
OnionSocket,
UniqueIdent,
AppName,
connectHiddenService,
addHiddenService,
getHiddenServiceSocketFile,
torIsInstalled,
) where
import Common
import Utility.ThreadScheduler

View file

@ -5,7 +5,11 @@
- License: BSD-2-clause
-}
module Utility.Tuple where
module Utility.Tuple (
fst3,
snd3,
thd3,
) where
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a

View file

@ -5,7 +5,14 @@
- License: BSD-2-clause
-}
module Utility.Verifiable where
module Utility.Verifiable (
Secret,
HMACDigest,
Verifiable(..),
mkVerifiable,
verify,
prop_verifiable_sane,
) where
import Data.ByteString.UTF8 (fromString)
import qualified Data.ByteString as S

View file

@ -7,7 +7,14 @@
{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-}
module Utility.WebApp where
module Utility.WebApp (
browserProc,
runWebApp,
webAppSessionBackend,
checkAuthToken,
insertAuthToken,
writeHtmlShim,
) where
import Common
import Utility.Tmp
@ -19,11 +26,9 @@ import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Network.HTTP.Types
import qualified Data.CaseInsensitive as CI
import Network.Socket
import "crypto-api" Crypto.Random
import qualified Web.ClientSession as CS
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
@ -119,9 +124,6 @@ getSocket h = do
listen sock maxListenQueue
return sock
lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString
lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
{- Rather than storing a session key on disk, use a random key
- that will only be valid for this run of the webapp. -}
webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend)
@ -188,7 +190,6 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params =
writeHtmlShim :: String -> String -> FilePath -> IO ()
writeHtmlShim title url file = viaTmp writeFileProtected file $ genHtmlShim title url
{- TODO: generate this static file using Yesod. -}
genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines
[ "<html>"