diff options
Diffstat (limited to 'Utility')
39 files changed, 183 insertions, 126 deletions
diff --git a/Utility/Base64.hs b/Utility/Base64.hs index 80cc122a1..6ab3c984f 100644 --- a/Utility/Base64.hs +++ b/Utility/Base64.hs @@ -1,23 +1,22 @@ {- Simple Base64 encoding of Strings - - - Copyright 2011 Joey Hess <id@joeyh.name> + - Copyright 2011, 2015 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} module Utility.Base64 (toB64, fromB64Maybe, fromB64, prop_b64_roundtrips) where -import qualified "dataenc" Codec.Binary.Base64 as B64 -import Control.Applicative +import qualified "sandi" Codec.Binary.Base64 as B64 import Data.Maybe -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.ByteString.UTF8 (fromString, toString) toB64 :: String -> String -toB64 = B64.encode . L.unpack . fromString +toB64 = toString . B64.encode . fromString fromB64Maybe :: String -> Maybe String -fromB64Maybe s = toString . L.pack <$> B64.decode s +fromB64Maybe s = either (const Nothing) (Just . toString) + (B64.decode $ fromString s) fromB64 :: String -> String fromB64 = fromMaybe bad . fromB64Maybe diff --git a/Utility/Bloom.hs b/Utility/Bloom.hs index aee760a1d..95ade6d32 100644 --- a/Utility/Bloom.hs +++ b/Utility/Bloom.hs @@ -27,7 +27,7 @@ import qualified Data.BloomFilter as Bloom #endif import Data.BloomFilter.Easy (safeSuggestSizing, Bloom) import Data.BloomFilter.Hash (Hashable, cheapHashes) -import Control.Monad.ST.Safe (ST) +import Control.Monad.ST (ST) #if MIN_VERSION_bloomfilter(2,0,0) diff --git a/Utility/CopyFile.hs b/Utility/CopyFile.hs index b123d006d..1c07ca110 100644 --- a/Utility/CopyFile.hs +++ b/Utility/CopyFile.hs @@ -16,7 +16,12 @@ module Utility.CopyFile ( import Common import qualified Build.SysConfig as SysConfig -data CopyMetaData = CopyTimeStamps | CopyAllMetaData +data CopyMetaData + -- Copy timestamps when possible, but no other metadata, and + -- when copying a symlink, makes a copy of its content. + = CopyTimeStamps + -- Copy all metadata when possible. + | CopyAllMetaData deriving (Eq) {- The cp command is used, because I hate reinventing the wheel, diff --git a/Utility/Data.hs b/Utility/Data.hs index 5ecd218fb..27c0a824c 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Data where {- First item in the list that is not Nothing. -} diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 3d3c14619..bde710626 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -57,7 +57,7 @@ eventsCoalesce = False #if (WITH_KQUEUE || WITH_FSEVENTS) eventsCoalesce = True #else -eventsCoalesce = undefined +eventsCoalesce = error "eventsCoalesce not defined" #endif #endif @@ -78,7 +78,7 @@ closingTracked = True #if WITH_KQUEUE closingTracked = False #else -closingTracked = undefined +closingTracked = error "closingTracked not defined" #endif #endif @@ -93,7 +93,7 @@ modifyTracked = True #if WITH_KQUEUE modifyTracked = False #else -modifyTracked = undefined +modifyTracked = error "modifyTracked not defined" #endif #endif @@ -131,7 +131,7 @@ watchDir dir prune scanevents hooks runstartup = #else type DirWatcherHandle = () watchDir :: FilePath -> Pruner -> Bool -> WatchHooks -> (IO () -> IO ()) -> IO DirWatcherHandle -watchDir = undefined +watchDir = error "watchDir not defined" #endif #endif #endif @@ -150,7 +150,7 @@ stopWatchDir = FSEvents.eventStreamDestroy #if WITH_WIN32NOTIFY stopWatchDir = Win32Notify.killWatchManager #else -stopWatchDir = undefined +stopWatchDir = error "stopWatchDir not defined" #endif #endif #endif diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 85ec8bf45..7322cd85f 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Directory where @@ -18,6 +19,7 @@ import Control.Applicative import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe +import Prelude #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 @@ -111,7 +113,7 @@ moveFile src dest = tryIO (rename src dest) >>= onrename -- But, mv will move into a directory if -- dest is one, which is not desired. whenM (isdir dest) rethrow - viaTmp mv dest undefined + viaTmp mv dest "" where rethrow = throwM e mv tmp _ = do diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index 67e40ff3c..ebf4c0bd1 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.DottedVersion where import Common diff --git a/Utility/Env.hs b/Utility/Env.hs index fdf06d807..c56f4ec23 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Env where @@ -13,6 +14,7 @@ module Utility.Env where import Utility.Exception import Control.Applicative import Data.Maybe +import Prelude import qualified System.Environment as E import qualified System.SetEnv #else diff --git a/Utility/Exception.hs b/Utility/Exception.hs index ab47ae95f..9d4236c47 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( module X, diff --git a/Utility/ExternalSHA.hs b/Utility/ExternalSHA.hs index 6cef2830d..0defbaa16 100644 --- a/Utility/ExternalSHA.hs +++ b/Utility/ExternalSHA.hs @@ -8,6 +8,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.ExternalSHA (externalSHA) where import Utility.SafeCommand @@ -18,8 +20,9 @@ import Utility.Exception import Data.List import Data.Char -import Control.Applicative import System.IO +import Control.Applicative +import Prelude externalSHA :: String -> Int -> FilePath -> IO (Either String String) externalSHA command shasize file = do diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 5c4001ed8..201b8451c 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -124,7 +124,7 @@ withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode -combineModes [] = undefined +combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -151,7 +151,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = withUmask 0o0077 $ +writeFileProtected file content = writeFileProtected' file + (\h -> hPutStr h content) + +writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' file writer = withUmask 0o0077 $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes - hPutStr h content + writer h diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 139b74fe4..41c5972a0 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( fileEncoding, diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs index ee1c2f302..70332490b 100644 --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -10,6 +10,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.FreeDesktop ( DesktopEntry, genDesktopEntry, @@ -39,6 +41,7 @@ import Data.List import Data.String.Utils import Data.Maybe import Control.Applicative +import Prelude type DesktopEntry = [(Key, Value)] diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 6323d3a00..a1b782d97 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -9,14 +9,8 @@ module Utility.Gpg where -import Control.Applicative -import Control.Concurrent -import Control.Monad.IO.Class -import qualified Data.Map as M - import Common import qualified Build.SysConfig as SysConfig - #ifndef mingw32_HOST_OS import System.Posix.Types import qualified System.Posix.IO @@ -27,6 +21,10 @@ import Utility.Tmp #endif import Utility.Format (decode_c) +import Control.Concurrent +import Control.Monad.IO.Class +import qualified Data.Map as M + type KeyId = String newtype KeyIds = KeyIds { keyIds :: [KeyId] } diff --git a/Utility/Hash.hs b/Utility/Hash.hs index 9881815bd..f960a134f 100644 --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -9,13 +9,16 @@ module Utility.Hash ( skein256, skein512, md5, - prop_hashes_stable + prop_hashes_stable, + Mac(..), + calcMac, + prop_mac_stable, ) where import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Data.Text.Encoding as T - +import qualified Data.ByteString as S import Crypto.Hash sha1 :: L.ByteString -> Digest SHA1 @@ -60,3 +63,37 @@ prop_hashes_stable = all (\(hasher, result) -> hasher foo == result) ] where foo = L.fromChunks [T.encodeUtf8 $ T.pack "foo"] + +{- File names are (client-side) MAC'ed on special remotes. + - The chosen MAC algorithm needs to be same for all files stored on the + - remote. + -} +data Mac = HmacSha1 | HmacSha224 | HmacSha256 | HmacSha384 | HmacSha512 + deriving (Eq) + +calcMac + :: Mac -- ^ MAC + -> S.ByteString -- ^ secret key + -> S.ByteString -- ^ message + -> String -- ^ MAC'ed message, in hexadecimal +calcMac mac = case mac of + HmacSha1 -> use SHA1 + HmacSha224 -> use SHA224 + HmacSha256 -> use SHA256 + HmacSha384 -> use SHA384 + HmacSha512 -> use SHA512 + where + use alg k m = show (hmacGetDigest (hmacAlg alg k m)) + +-- Check that all the MACs continue to produce the same. +prop_mac_stable :: Bool +prop_mac_stable = all (\(mac, result) -> calcMac mac key msg == result) + [ (HmacSha1, "46b4ec586117154dacd49d664e5d63fdc88efb51") + , (HmacSha224, "4c1f774863acb63b7f6e9daa9b5c543fa0d5eccf61e3ffc3698eacdd") + , (HmacSha256, "f9320baf0249169e73850cd6156ded0106e2bb6ad8cab01b7bbbebe6d1065317") + , (HmacSha384, "3d10d391bee2364df2c55cf605759373e1b5a4ca9355d8f3fe42970471eca2e422a79271a0e857a69923839015877fc6") + , (HmacSha512, "114682914c5d017dfe59fdc804118b56a3a652a0b8870759cf9e792ed7426b08197076bf7d01640b1b0684df79e4b67e37485669e8ce98dbab60445f0db94fce") + ] + where + key = T.encodeUtf8 $ T.pack "foo" + msg = T.encodeUtf8 $ T.pack "bar" diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index 85a9e15b6..e8fdb7c6e 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -20,11 +20,12 @@ import Utility.PartialPrelude import Utility.Applicative import Utility.QuickCheck +import qualified Data.Map as M import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) import Data.Char import Control.Applicative -import qualified Data.Map as M +import Prelude newtype Duration = Duration { durationSeconds :: Integer } deriving (Eq, Ord, Read, Show) diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index db64d1236..fdeb77959 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -7,7 +7,12 @@ module Utility.LinuxMkLibs where -import Control.Applicative +import Utility.PartialPrelude +import Utility.Directory +import Utility.Process +import Utility.Monad +import Utility.Path + import Data.Maybe import System.Directory import System.FilePath @@ -15,12 +20,8 @@ import Data.List.Utils import System.Posix.Files import Data.Char import Control.Monad.IfElse - -import Utility.PartialPrelude -import Utility.Directory -import Utility.Process -import Utility.Monad -import Utility.Path +import Control.Applicative +import Prelude {- Installs a library. If the library is a symlink to another file, - install the file it links to, and update the symlink to be relative. -} diff --git a/Utility/Metered.hs b/Utility/Metered.hs index f94b5d121..c34e931a4 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -144,7 +144,7 @@ defaultChunkSize :: Int defaultChunkSize = 32 * k - chunkOverhead where k = 1024 - chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific + chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific data OutputHandler = OutputHandler { quietMode :: Bool diff --git a/Utility/Misc.hs b/Utility/Misc.hs index e4eccac43..45d5a0639 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -6,23 +6,25 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc where +import Utility.FileSystemEncoding +import Utility.Monad + import System.IO import Control.Monad import Foreign import Data.Char import Data.List -import Control.Applicative import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif - -import Utility.FileSystemEncoding -import Utility.Monad +import Control.Applicative +import Prelude {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} diff --git a/Utility/Monad.hs b/Utility/Monad.hs index 878e0da67..ac751043c 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Monad where import Data.Maybe diff --git a/Utility/Mounts.hsc b/Utility/Mounts.hsc index 1fb2362df..ad4adf334 100644 --- a/Utility/Mounts.hsc +++ b/Utility/Mounts.hsc @@ -26,6 +26,7 @@ import Utility.Exception import Data.Maybe import Control.Applicative #endif +import Prelude {- This is a stripped down mntent, containing only - fields available everywhere. -} diff --git a/Utility/Network.hs b/Utility/Network.hs index 7f228e155..4def3c5c5 100644 --- a/Utility/Network.hs +++ b/Utility/Network.hs @@ -5,12 +5,15 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.Network where import Utility.Process import Utility.Exception import Control.Applicative +import Prelude {- Haskell lacks uname(2) bindings, except in the - Bindings.Uname addon. Rather than depend on that, diff --git a/Utility/OSX.hs b/Utility/OSX.hs index 22028e210..f6aba5096 100644 --- a/Utility/OSX.hs +++ b/Utility/OSX.hs @@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.OSX where import Utility.UserInfo diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs index 6efa093fd..557955633 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -5,6 +5,8 @@ - them being accidentially used. -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.PartialPrelude where import qualified Data.Maybe diff --git a/Utility/Path.hs b/Utility/Path.hs index 9f0737fe8..8e3c2bddb 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE PackageImports, CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Path where @@ -16,6 +17,7 @@ import Data.List import Data.Maybe import Data.Char import Control.Applicative +import Prelude #ifdef mingw32_HOST_OS import qualified System.FilePath.Posix as Posix diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs index 5a94ead01..4550bebdf 100644 --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -8,6 +8,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.PosixFiles ( module X, diff --git a/Utility/Process.hs b/Utility/Process.hs index cbbe8a811..9f98596be 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( module X, @@ -54,6 +55,7 @@ import qualified System.Posix.IO import Control.Applicative #endif import Data.Maybe +import Prelude import Utility.Misc import Utility.Exception diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 54200d3f7..cd408ddc9 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -19,6 +19,7 @@ import System.Posix.Types import qualified Data.Map as M import qualified Data.Set as S import Control.Applicative +import Prelude instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where arbitrary = M.fromList <$> arbitrary diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs index 0669e7351..0412116a1 100644 --- a/Utility/Quvi.hs +++ b/Utility/Quvi.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Utility.Quvi where @@ -30,7 +31,7 @@ data Page = Page } deriving (Show) data Link = Link - { linkSuffix :: String + { linkSuffix :: Maybe String , linkUrl :: URLString } deriving (Show) @@ -43,7 +44,7 @@ instance FromJSON Page where instance FromJSON Link where parseJSON (Object v) = Link - <$> v .: "file_suffix" + <$> v .:? "file_suffix" <*> v .: "url" parseJSON _ = mzero @@ -53,7 +54,7 @@ parseEnum s = Page <$> get "QUVI_MEDIA_PROPERTY_TITLE" <*> ((:[]) <$> ( Link - <$> get "QUVI_MEDIA_STREAM_PROPERTY_CONTAINER" + <$> Just <$> (get "QUVI_MEDIA_STREAM_PROPERTY_CONTAINER") <*> get "QUVI_MEDIA_STREAM_PROPERTY_URL" ) ) diff --git a/Utility/SRV.hs b/Utility/SRV.hs index 203585a7e..b6d57dea5 100644 --- a/Utility/SRV.hs +++ b/Utility/SRV.hs @@ -25,8 +25,9 @@ import Utility.PartialPrelude import Network import Data.Function import Data.List -import Control.Applicative import Data.Maybe +import Control.Applicative +import Prelude #ifdef WITH_ADNS import ADNS.Resolver diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index f44112b82..0704e69f7 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,18 +1,21 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -} +{-# OPTIONS_GHC -fno-warn-tabs #-} + module Utility.SafeCommand where import System.Exit import Utility.Process import Data.String.Utils -import Control.Applicative import System.FilePath import Data.Char +import Control.Applicative +import Prelude {- A type for parameters passed to a shell command. A command can - be passed either some Params (multiple parameters can be included, @@ -44,23 +47,32 @@ toCommand = concatMap unwrap - if it succeeded or failed. -} boolSystem :: FilePath -> [CommandParam] -> IO Bool -boolSystem command params = boolSystemEnv command params Nothing +boolSystem command params = boolSystem' command params id -boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ +boolSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +boolSystem' command params mkprocess = dispatch <$> safeSystem' command params mkprocess where dispatch ExitSuccess = True dispatch _ = False +boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool +boolSystemEnv command params environ = boolSystem' command params $ + \p -> p { env = environ } + {- Runs a system command, returning the exit status. -} safeSystem :: FilePath -> [CommandParam] -> IO ExitCode -safeSystem command params = safeSystemEnv command params Nothing +safeSystem command params = safeSystem' command params id -safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv command params environ = do - (_, _, _, pid) <- createProcess (proc command $ toCommand params) - { env = environ } +safeSystem' :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO ExitCode +safeSystem' command params mkprocess = do + (_, _, _, pid) <- createProcess p waitForProcess pid + where + p = mkprocess $ proc command (toCommand params) + +safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode +safeSystemEnv command params environ = safeSystem' command params $ + \p -> p { env = environ } {- Wraps a shell command line inside sh -c, allowing it to be run in a - login shell that may not support POSIX shell, eg csh. -} diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs index e077a1fea..b3813323d 100644 --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -32,7 +32,6 @@ import Utility.QuickCheck import Utility.PartialPrelude import Utility.Misc -import Control.Applicative import Data.List import Data.Time.Clock import Data.Time.LocalTime @@ -41,6 +40,8 @@ import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate import Data.Tuple.Utils import Data.Char +import Control.Applicative +import Prelude {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index dc5598137..de970fe56 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp where diff --git a/Utility/Touch.hsc b/Utility/Touch.hsc index f87bb62d6..c3318e6da 100644 --- a/Utility/Touch.hsc +++ b/Utility/Touch.hsc @@ -54,8 +54,8 @@ instance Storable TimeSpec where -- use the larger alignment of the two types in the struct alignment _ = max sec_alignment nsec_alignment where - sec_alignment = alignment (undefined::CTime) - nsec_alignment = alignment (undefined::CLong) + sec_alignment = alignment (1::CTime) + nsec_alignment = alignment (1::CLong) sizeOf _ = #{size struct timespec} peek ptr = do sec <- #{peek struct timespec, tv_sec} ptr @@ -92,7 +92,7 @@ touchBoth file atime mtime follow = -} instance Storable TimeSpec where - alignment _ = alignment (undefined::CLong) + alignment _ = alignment (1::CLong) sizeOf _ = #{size struct timeval} peek ptr = do sec <- #{peek struct timeval, tv_sec} ptr diff --git a/Utility/Url.hs b/Utility/Url.hs index 1b0c394b7..2ef1167e5 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -8,6 +8,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Utility.Url ( URLString, @@ -25,6 +26,9 @@ module Utility.Url ( ) where import Common +import Utility.Tmp +import qualified Build.SysConfig + import Network.URI import Network.HTTP.Conduit import Network.HTTP.Types @@ -32,8 +36,6 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as B8 -import qualified Build.SysConfig - type URLString = String type Headers = [String] @@ -122,10 +124,14 @@ getUrlInfo url uo = case parseURIRelaxed url of | Build.SysConfig.curl -> do output <- catchDefaultIO "" $ readProcess "curl" $ toCommand curlparams + let len = extractlencurl output + let good = found len Nothing case lastMaybe (lines output) of - Just ('2':_:_) -> found - (extractlencurl output) - Nothing + Just ('2':_:_) -> good + -- don't try to parse ftp status + -- codes; if curl got a length, + -- it's good + _ | "ftp" `isInfixOf` uriScheme u && isJust len -> good _ -> dne | otherwise -> dne Nothing -> dne @@ -242,8 +248,15 @@ download' quiet url file uo = do writeFile file "" go "curl" $ headerparams ++ quietopt "-s" ++ [Params "-f -L -C - -# -o"] - go cmd opts = boolSystem cmd $ - addUserAgent uo $ reqParams uo++opts++[File file, File url] + + {- Run wget in a temp directory because it has been buggy + - and overwritten files in the current directory, even though + - it was asked to write to a file elsewhere. -} + go cmd opts = withTmpDir "downloadurl" $ \tmp -> do + absfile <- absPath file + let ps = addUserAgent uo $ reqParams uo++opts++[File absfile, File url] + boolSystem' cmd ps $ \p -> p { cwd = Just tmp } + quietopt s | quiet = [Param s] | otherwise = [] diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 5bf8d5c09..7e94cafa4 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.UserInfo ( myHomeDir, @@ -13,12 +14,13 @@ module Utility.UserInfo ( myUserGecos, ) where +import Utility.Env + import System.PosixCompat #ifndef mingw32_HOST_OS import Control.Applicative #endif - -import Utility.Env +import Prelude {- Current user's home directory. - diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs index a861416e2..278c320ae 100644 --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -7,11 +7,12 @@ module Utility.Verifiable where -import Data.Digest.Pure.SHA -import Data.ByteString.Lazy.UTF8 (fromString) -import qualified Data.ByteString.Lazy as L +import Data.ByteString.UTF8 (fromString) +import qualified Data.ByteString as S -type Secret = L.ByteString +import Utility.Hash + +type Secret = S.ByteString type HMACDigest = String {- A value, verifiable using a HMAC digest and a secret. -} @@ -28,7 +29,7 @@ verify :: (Eq a, Show a) => Verifiable a -> Secret -> Bool verify v secret = v == mkVerifiable (verifiableVal v) secret calcDigest :: String -> Secret -> HMACDigest -calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v +calcDigest v secret = calcMac HmacSha1 secret (fromString v) {- for quickcheck -} prop_verifiable_sane :: String -> String -> Bool diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 54f2d6f2b..ce6a61c42 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -94,11 +94,7 @@ fixSockAddr addr = addr -- disable buggy sloworis attack prevention code webAppSettings :: Settings -#if MIN_VERSION_warp(2,1,0) webAppSettings = setTimeout halfhour defaultSettings -#else -webAppSettings = defaultSettings { settingsTimeout = halfhour } -#endif where halfhour = 30 * 60 @@ -155,11 +151,7 @@ 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. -} -#if MIN_VERSION_yesod(1,2,0) webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe Yesod.SessionBackend) -#else -webAppSessionBackend :: Yesod.Yesod y => y -> IO (Maybe (Yesod.SessionBackend y)) -#endif webAppSessionBackend _ = do g <- newGenIO :: IO SystemRandom case genBytes 96 g of @@ -170,18 +162,8 @@ webAppSessionBackend _ = do where timeout = 120 * 60 -- 120 minutes use key = -#if MIN_VERSION_yesod(1,2,0) Just . Yesod.clientSessionBackend key . fst <$> Yesod.clientSessionDateCacher timeout -#else -#if MIN_VERSION_yesod(1,1,7) - Just . Yesod.clientSessionBackend2 key . fst - <$> Yesod.clientSessionDateCacher timeout -#else - return $ Just $ - Yesod.clientSessionBackend key timeout -#endif -#endif #ifdef WITH_WEBAPP_SECURE type AuthToken = SecureMem @@ -219,11 +201,7 @@ genAuthToken = do - Note that the usual Yesod error page is bypassed on error, to avoid - possibly leaking the auth token in urls on that page! -} -#if MIN_VERSION_yesod(1,2,0) checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> AuthToken) -> m Yesod.AuthResult -#else -checkAuthToken :: forall t sub. (t -> AuthToken) -> Yesod.GHandler sub t Yesod.AuthResult -#endif checkAuthToken extractAuthToken = do webapp <- Yesod.getYesod req <- Yesod.getRequest diff --git a/Utility/Yesod.hs b/Utility/Yesod.hs index 231bb291e..a8055d34d 100644 --- a/Utility/Yesod.hs +++ b/Utility/Yesod.hs @@ -20,69 +20,37 @@ module Utility.Yesod #if ! MIN_VERSION_yesod(1,4,0) , withUrlRenderer #endif -#if ! MIN_VERSION_yesod(1,2,0) - , Html -#endif ) where -#if MIN_VERSION_yesod(1,2,0) import Yesod as Y -#else -import Yesod as Y hiding (Html) -#endif -#if MIN_VERSION_yesod_form(1,3,8) import Yesod.Form.Bootstrap3 as Y hiding (bfs) -#else -import Assistant.WebApp.Bootstrap3 as Y hiding (bfs) -#endif #ifndef __NO_TH__ import Yesod.Default.Util import Language.Haskell.TH.Syntax (Q, Exp) -#if MIN_VERSION_yesod_default(1,1,0) import Data.Default (def) import Text.Hamlet hiding (Html) #endif -#endif #if ! MIN_VERSION_yesod(1,4,0) -#if MIN_VERSION_yesod(1,2,0) import Data.Text (Text) #endif -#endif #ifndef __NO_TH__ widgetFile :: String -> Q Exp -#if ! MIN_VERSION_yesod_default(1,1,0) -widgetFile = widgetFileNoReload -#else widgetFile = widgetFileNoReload $ def { wfsHamletSettings = defaultHamletSettings { hamletNewlines = AlwaysNewlines } } -#endif hamletTemplate :: FilePath -> FilePath hamletTemplate f = globFile "hamlet" f #endif {- Lift Handler to Widget -} -#if MIN_VERSION_yesod(1,2,0) liftH :: Monad m => HandlerT site m a -> WidgetT site m a liftH = handlerToWidget -#else -liftH :: MonadLift base m => base a -> m a -liftH = lift -#endif -{- Misc new names for stuff. -} -#if ! MIN_VERSION_yesod(1,2,0) -withUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml -withUrlRenderer = hamletToRepHtml - -type Html = RepHtml -#else #if ! MIN_VERSION_yesod_core(1,2,20) withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output withUrlRenderer = giveUrlRenderer #endif -#endif |