diff --git a/.mailmap b/.mailmap index 275b236df9..3013a39355 100644 --- a/.mailmap +++ b/.mailmap @@ -1,7 +1,28 @@ +Antoine Beaupré anarcat +Antoine Beaupré https://id.koumbit.net/anarcat +Greg Grossmeier http://grossmeier.net/ +Jimmy Tang jtang +Joachim Breitner http://www.joachim-breitner.de/ +Joey Hess Joey Hess +Joey Hess Joey Hess +Joey Hess Joey Hess +Joey Hess Joey Hess +Joey Hess Joey Hess +Joey Hess Joey Hess +Joey Hess Joey Hess Joey Hess http://joey.kitenet.net/ -Joey Hess http://joeyh.name/ Joey Hess http://joeyh.name/ +Joey Hess http://joeyh.name/ +Joey Hess https://www.google.com/accounts/o8/id?id=AItOawmJfIszzreLNvCqzqzvTayA9_9L6gb9RtY +Johan Kiviniemi http://johan.kiviniemi.name/ +Johan Kiviniemi http://johan.kiviniemi.name/ +Nicolas Pouillard http://ertai.myopenid.com/ +Peter Simons Peter Simons +Peter Simons http://peter-simons.myopenid.com/ +Philipp Kern http://phil.0x539.de/ +Richard Hartmann https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U Yaroslav Halchenko Yaroslav Halchenko http://yarikoptic.myopenid.com/ Yaroslav Halchenko https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY -Richard Hartmann https://www.google.com/accounts/o8/id?id=AItOawl9sYlePmv1xK-VvjBdN-5doOa_Xw-jH4U +Øyvind A. Holm http://sunny256.sunbase.org/ +Øyvind A. Holm https://sunny256.wordpress.com/ diff --git a/Annex.hs b/Annex.hs index d3425c7e23..b0ebd81ae5 100644 --- a/Annex.hs +++ b/Annex.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PackageImports, BangPatterns #-} module Annex ( Annex, @@ -32,6 +32,7 @@ module Annex ( getRemoteGitConfig, withCurrentState, changeDirectory, + incError, ) where import Common @@ -312,3 +313,9 @@ changeDirectory d = do liftIO $ setCurrentDirectory d r' <- liftIO $ Git.relPath r changeState $ \s -> s { repo = r' } + +incError :: Annex () +incError = changeState $ \s -> + let ! c = errcounter s + 1 + ! s' = s { errcounter = c } + in s' diff --git a/Annex/Content.hs b/Annex/Content.hs index 9d70ccee33..dc60dfe1a9 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -280,17 +280,19 @@ withTmp key action = do {- Checks that there is disk space available to store a given key, - in a destination (or the annex) printing a warning if not. -} checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool -checkDiskSpace destination key alreadythere = do - reserve <- annexDiskReserve <$> Annex.getGitConfig - free <- liftIO . getDiskFree =<< dir - force <- Annex.getState Annex.force - case (free, keySize key) of - (Just have, Just need) -> do - let ok = (need + reserve <= have + alreadythere) || force - unless ok $ - needmorespace (need + reserve - have - alreadythere) - return ok - _ -> return True +checkDiskSpace destination key alreadythere = ifM (Annex.getState Annex.force) + ( return True + , do + reserve <- annexDiskReserve <$> Annex.getGitConfig + free <- liftIO . getDiskFree =<< dir + case (free, fromMaybe 1 (keySize key)) of + (Just have, need) -> do + let ok = (need + reserve <= have + alreadythere) + unless ok $ + needmorespace (need + reserve - have - alreadythere) + return ok + _ -> return True + ) where dir = maybe (fromRepo gitAnnexDir) return destination needmorespace n = @@ -498,9 +500,9 @@ getKeysPresent keyloc = do direct <- isDirect dir <- fromRepo gitAnnexObjectDir s <- getstate direct - liftIO $ traverse s direct (2 :: Int) dir + liftIO $ walk s direct (2 :: Int) dir where - traverse s direct depth dir = do + walk s direct depth dir = do contents <- catchDefaultIO [] (dirContents dir) if depth == 0 then do @@ -508,7 +510,7 @@ getKeysPresent keyloc = do let keys = mapMaybe (fileKey . takeFileName) contents' continue keys [] else do - let deeper = traverse s direct (depth - 1) + let deeper = walk s direct (depth - 1) continue [] (map deeper contents) continue keys [] = return keys continue keys (a:as) = do diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 0ea815db27..973e51348a 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -9,7 +9,7 @@ module Annex.Drop where import Common.Annex import Logs.Trust -import Config.NumCopies +import Annex.NumCopies import Types.Remote (uuid) import Types.Key (key2file) import qualified Remote diff --git a/Annex/Init.hs b/Annex/Init.hs index 50f4d8522b..2cc1c18973 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -57,15 +57,15 @@ genDescription Nothing = do initialize :: Maybe String -> Annex () initialize mdescription = do + {- This will make the first commit to git, so ensure git is set up + - properly to allow commits when running it. -} + ensureCommit $ Annex.Branch.create + prepUUID initialize' u <- getUUID - {- This will make the first commit to git, so ensure git is set up - - properly to allow commits when running it. -} - ensureCommit $ do - Annex.Branch.create - describeUUID u =<< genDescription mdescription + describeUUID u =<< genDescription mdescription -- Everything except for uuid setup. initialize' :: Annex () diff --git a/Config/NumCopies.hs b/Annex/NumCopies.hs similarity index 50% rename from Config/NumCopies.hs rename to Annex/NumCopies.hs index 50dcdf6842..8795139277 100644 --- a/Config/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -1,11 +1,11 @@ -{- git-annex numcopies configuration +{- git-annex numcopies configuration and checking - - - Copyright 2014 Joey Hess + - Copyright 2014-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} -module Config.NumCopies ( +module Annex.NumCopies ( module Types.NumCopies, module Logs.NumCopies, getFileNumCopies, @@ -15,6 +15,8 @@ module Config.NumCopies ( defaultNumCopies, numCopiesCheck, numCopiesCheck', + verifyEnoughCopies, + knownCopies, ) where import Common.Annex @@ -24,6 +26,8 @@ import Logs.NumCopies import Logs.Trust import Annex.CheckAttr import qualified Remote +import Annex.UUID +import Annex.Content defaultNumCopies :: NumCopies defaultNumCopies = NumCopies 1 @@ -83,3 +87,61 @@ numCopiesCheck' :: FilePath -> (Int -> Int -> v) -> [UUID] -> Annex v numCopiesCheck' file vs have = do NumCopies needed <- getFileNumCopies file return $ length have `vs` needed + +{- Verifies that enough copies of a key exist amoung the listed remotes, + - priting an informative message if not. + -} +verifyEnoughCopies + :: String -- message to print when there are no known locations + -> Key + -> NumCopies + -> [UUID] -- repos to skip (generally untrusted remotes) + -> [UUID] -- repos that are trusted or already verified to have it + -> [Remote] -- remotes to check to see if they have it + -> Annex Bool +verifyEnoughCopies nolocmsg key need skip trusted tocheck = + helper [] [] (nub trusted) (nub tocheck) + where + helper bad missing have [] + | NumCopies (length have) >= need = return True + | otherwise = do + notEnoughCopies key need have (skip++missing) bad nolocmsg + return False + helper bad missing have (r:rs) + | NumCopies (length have) >= need = return True + | otherwise = do + let u = Remote.uuid r + let duplicate = u `elem` have + haskey <- Remote.hasKey r key + case (duplicate, haskey) of + (False, Right True) -> helper bad missing (u:have) rs + (False, Left _) -> helper (r:bad) missing have rs + (False, Right False) -> helper bad (u:missing) have rs + _ -> helper bad missing have rs + +notEnoughCopies :: Key -> NumCopies -> [UUID] -> [UUID] -> [Remote] -> String -> Annex () +notEnoughCopies key need have skip bad nolocmsg = do + showNote "unsafe" + showLongNote $ + "Could only verify the existence of " ++ + show (length have) ++ " out of " ++ show (fromNumCopies need) ++ + " necessary copies" + Remote.showTriedRemotes bad + Remote.showLocations True key (have++skip) nolocmsg + +{- Cost ordered lists of remotes that the location log indicates + - may have a key. + - + - Also returns a list of UUIDs that are trusted to have the key + - (some may not have configured remotes). If the current repository + - currently has the key, and is not untrusted, it is included in this list. + -} +knownCopies :: Key -> Annex ([Remote], [UUID]) +knownCopies key = do + (remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key + u <- getUUID + trusteduuids' <- ifM (inAnnex key <&&> (<= SemiTrusted) <$> lookupTrust u) + ( pure (u:trusteduuids) + , pure trusteduuids + ) + return (remotes, trusteduuids') diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 3ae351d8c8..06971173f6 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -69,14 +69,14 @@ annexFileMode = withShared $ return . go {- Creates a directory inside the gitAnnexDir, including any parent - directories. Makes directories with appropriate permissions. -} createAnnexDirectory :: FilePath -> Annex () -createAnnexDirectory dir = traverse dir [] =<< top +createAnnexDirectory dir = walk dir [] =<< top where top = parentDir <$> fromRepo gitAnnexDir - traverse d below stop + walk d below stop | d `equalFilePath` stop = done | otherwise = ifM (liftIO $ doesDirectoryExist d) ( done - , traverse (parentDir d) (d:below) stop + , walk (parentDir d) (d:below) stop ) where done = forM_ below $ \p -> do diff --git a/Assistant.hs b/Assistant.hs index fb04f51106..265827a773 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -57,7 +57,6 @@ import Utility.LogFile #ifdef mingw32_HOST_OS import Utility.Env import Annex.Path -import Config.Files import System.Environment (getArgs) #endif diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 1ed40595e1..4c42ffdbe2 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -16,6 +16,7 @@ import Assistant.Types.NetMessager import Utility.NotificationBroadcaster import Logs.Transfer import Logs.Trust +import Logs.TimeStamp import qualified Remote import qualified Types.Remote as Remote import qualified Git @@ -23,8 +24,6 @@ import qualified Git import Control.Concurrent.STM import System.Posix.Types import Data.Time.Clock.POSIX -import Data.Time -import System.Locale import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -125,21 +124,18 @@ readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file where parse status = foldr parseline status . lines parseline line status - | key == "lastRunning" = parseval readtime $ \v -> + | key == "lastRunning" = parseval parsePOSIXTime $ \v -> status { lastRunning = Just v } | key == "scanComplete" = parseval readish $ \v -> status { scanComplete = v } | key == "sanityCheckRunning" = parseval readish $ \v -> status { sanityCheckRunning = v } - | key == "lastSanityCheck" = parseval readtime $ \v -> + | key == "lastSanityCheck" = parseval parsePOSIXTime $ \v -> status { lastSanityCheck = Just v } | otherwise = status -- unparsable line where (key, value) = separate (== ':') line parseval parser a = maybe status a (parser value) - readtime s = do - d <- parseTime defaultTimeLocale "%s%Qs" s - Just $ utcTimeToPOSIXSeconds d {- Checks if a time stamp was made after the daemon was lastRunning. - diff --git a/Assistant/Install.hs b/Assistant/Install.hs index 6da6d2389a..00d719becc 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -145,10 +145,12 @@ installFileManagerHooks program = do , "Name=" ++ command , "Icon=git-annex" , unwords - [ "Exec=sh -c 'cd \"$(dirname '%U')\" &&" + [ "Exec=sh -c 'cd \"$(dirname \"$1\")\" &&" , program , command - , "--notify-start --notify-finish -- %U'" + , "--notify-start --notify-finish -- \"$1\"'" + , "false" -- this becomes $0 in sh, so unused + , "%f" ] ] #else diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs index b27b697750..57450304b3 100644 --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Assistant.Install.AutoStart where diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs index 32393abafd..dd21ee117e 100644 --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} module Assistant.Install.Menu where diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index b24e5fdb61..2390379e22 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -81,6 +81,8 @@ data PairingInProgress = PairingInProgress } deriving (Show) +data AddrClass = IPv4AddrClass | IPv6AddrClass + data SomeAddr = IPv4Addr HostAddress {- My Android build of the Network library does not currently have IPV6 - support. -} diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 05533e2708..e2e120e224 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -88,8 +88,8 @@ bestHostName msg = case remoteHostName $ pairMsgData msg of fallback = do let a = pairMsgAddr msg let sockaddr = case a of - IPv4Addr addr -> SockAddrInet (PortNum 0) addr - IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0 + IPv4Addr addr -> SockAddrInet (fromInteger 0) addr + IPv6Addr addr -> SockAddrInet6 (fromInteger 0) 0 addr 0 fromMaybe (showAddr a) <$> catchDefaultIO Nothing (fst <$> getNameInfo [] True False sockaddr) diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 7a4ac3ffe5..694dcbbcc3 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -33,9 +33,9 @@ pairingPort = 55556 {- Goal: Reach all hosts on the same network segment. - Method: Use same address that avahi uses. Other broadcast addresses seem - to not be let through some routers. -} -multicastAddress :: SomeAddr -> HostName -multicastAddress (IPv4Addr _) = "224.0.0.251" -multicastAddress (IPv6Addr _) = "ff02::fb" +multicastAddress :: AddrClass -> HostName +multicastAddress IPv4AddrClass = "224.0.0.251" +multicastAddress IPv6AddrClass = "ff02::fb" {- Multicasts a message repeatedly on all interfaces, with a 2 second - delay between each transmission. The message is repeated forever @@ -62,7 +62,7 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats sendinterface cache i = void $ tryIO $ withSocketsDo $ bracket setup cleanup use where - setup = multicastSender (multicastAddress i) pairingPort + setup = multicastSender (multicastAddress IPv4AddrClass) pairingPort cleanup (sock, _) = sClose sock -- FIXME does not work use (sock, addr) = do setInterface sock (showAddr i) diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 717a99c964..f4af932859 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -196,7 +196,7 @@ maxCommitSize :: Int maxCommitSize = 5000 {- Decide if now is a good time to make a commit. - - Note that the list of changes has an undefined order. + - Note that the list of changes has a random order. - - Current strategy: If there have been 10 changes within the past second, - a batch activity is taking place, so wait for later. diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 023af53cba..3ccdd1adc8 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -63,11 +63,7 @@ dbusThread urlrenderer = do wasmounted <- liftIO $ swapMVar mvar nowmounted handleMounts urlrenderer wasmounted nowmounted liftIO $ forM_ mountChanged $ \matcher -> -#if MIN_VERSION_dbus(0,10,7) void $ addMatch client matcher handleevent -#else - listen client matcher handleevent -#endif , do liftAnnex $ warning "No known volume monitor available through dbus; falling back to mtab polling" diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index ad3a87a911..07ccdaf24e 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -112,11 +112,7 @@ checkNetMonitor client = do -} listenNMConnections :: Client -> (Bool -> IO ()) -> IO () listenNMConnections client setconnected = -#if MIN_VERSION_dbus(0,10,7) void $ addMatch client matcher -#else - listen client matcher -#endif $ \event -> mapM_ handleevent (map dictionaryItems $ mapMaybe fromVariant $ signalBody event) where @@ -166,11 +162,7 @@ listenWicdConnections client setconnected = do | any (== wicd_disconnected) status = setconnected False | otherwise = noop match matcher a = -#if MIN_VERSION_dbus(0,10,7) void $ addMatch client matcher a -#else - listen client matcher a -#endif #endif handleConnection :: Assistant () diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index e4f87494c8..ba2ae955cb 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -31,7 +31,7 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do where {- Note this can crash if there's no network interface, - or only one like lo that doesn't support multicast. -} - getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort + getsock = multicastReceiver (multicastAddress IPv4AddrClass) pairingPort go reqs cache sock = liftIO (getmsg sock []) >>= \msg -> case readish msg of Nothing -> go reqs cache sock diff --git a/Assistant/Threads/XMPPPusher.hs b/Assistant/Threads/XMPPPusher.hs index ec11b9b944..bff17356d7 100644 --- a/Assistant/Threads/XMPPPusher.hs +++ b/Assistant/Threads/XMPPPusher.hs @@ -78,4 +78,5 @@ selectNextPush lastpushedto l = go [] l (Pushing clientid _) | Just clientid /= lastpushedto -> (m, rejected ++ ms) _ -> go (m:rejected) ms - go [] [] = undefined + go [] [] = error "empty push queue" + diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs index f769657d01..4c15f133ae 100644 --- a/Assistant/Types/BranchChange.hs +++ b/Assistant/Types/BranchChange.hs @@ -8,7 +8,8 @@ module Assistant.Types.BranchChange where import Control.Concurrent.MSampleVar -import Common.Annex +import Control.Applicative +import Prelude newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ()) diff --git a/Assistant/WebApp/Bootstrap3.hs b/Assistant/WebApp/Bootstrap3.hs deleted file mode 100644 index 3fa20fc4dd..0000000000 --- a/Assistant/WebApp/Bootstrap3.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} --- | Helper functions for creating forms when using Bootstrap v3. --- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly --- modified to be compatible with Yesod 1.0.1 -module Assistant.WebApp.Bootstrap3 - ( -- * Rendering forms - renderBootstrap3 - , BootstrapFormLayout(..) - , BootstrapGridOptions(..) - -- * Field settings - , bfs - , withPlaceholder - , withAutofocus - , withLargeInput - , withSmallInput - -- * Submit button - , bootstrapSubmit - , mbootstrapSubmit - , BootstrapSubmit(..) - ) where - -import Control.Arrow (second) -import Control.Monad (liftM) -import Data.Text (Text) -import Data.String (IsString(..)) -import Yesod.Core - -import qualified Data.Text as T - -import Yesod.Form.Types -import Yesod.Form.Functions - --- | Create a new 'FieldSettings' with the classes that are --- required by Bootstrap v3. --- --- Since: yesod-form 1.3.8 -bfs :: RenderMessage site msg => msg -> FieldSettings site -bfs msg = - FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")] - - --- | Add a placeholder attribute to a field. If you need i18n --- for the placeholder, currently you\'ll need to do a hack and --- use 'getMessageRender' manually. --- --- Since: yesod-form 1.3.8 -withPlaceholder :: Text -> FieldSettings site -> FieldSettings site -withPlaceholder placeholder fs = fs { fsAttrs = newAttrs } - where newAttrs = ("placeholder", placeholder) : fsAttrs fs - - --- | Add an autofocus attribute to a field. --- --- Since: yesod-form 1.3.8 -withAutofocus :: FieldSettings site -> FieldSettings site -withAutofocus fs = fs { fsAttrs = newAttrs } - where newAttrs = ("autofocus", "autofocus") : fsAttrs fs - - --- | Add the @input-lg@ CSS class to a field. --- --- Since: yesod-form 1.3.8 -withLargeInput :: FieldSettings site -> FieldSettings site -withLargeInput fs = fs { fsAttrs = newAttrs } - where newAttrs = addClass "input-lg" (fsAttrs fs) - - --- | Add the @input-sm@ CSS class to a field. --- --- Since: yesod-form 1.3.8 -withSmallInput :: FieldSettings site -> FieldSettings site -withSmallInput fs = fs { fsAttrs = newAttrs } - where newAttrs = addClass "input-sm" (fsAttrs fs) - - -addClass :: Text -> [(Text, Text)] -> [(Text, Text)] -addClass klass [] = [("class", klass)] -addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest -addClass klass (other :rest) = other : addClass klass rest - - --- | How many bootstrap grid columns should be taken (see --- 'BootstrapFormLayout'). --- --- Since: yesod-form 1.3.8 -data BootstrapGridOptions = - ColXs !Int - | ColSm !Int - | ColMd !Int - | ColLg !Int - deriving (Eq, Ord, Show) - -toColumn :: BootstrapGridOptions -> String -toColumn (ColXs 0) = "" -toColumn (ColSm 0) = "" -toColumn (ColMd 0) = "" -toColumn (ColLg 0) = "" -toColumn (ColXs columns) = "col-xs-" ++ show columns -toColumn (ColSm columns) = "col-sm-" ++ show columns -toColumn (ColMd columns) = "col-md-" ++ show columns -toColumn (ColLg columns) = "col-lg-" ++ show columns - -toOffset :: BootstrapGridOptions -> String -toOffset (ColXs 0) = "" -toOffset (ColSm 0) = "" -toOffset (ColMd 0) = "" -toOffset (ColLg 0) = "" -toOffset (ColXs columns) = "col-xs-offset-" ++ show columns -toOffset (ColSm columns) = "col-sm-offset-" ++ show columns -toOffset (ColMd columns) = "col-md-offset-" ++ show columns -toOffset (ColLg columns) = "col-lg-offset-" ++ show columns - -addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions -addGO (ColXs a) (ColXs b) = ColXs (a+b) -addGO (ColSm a) (ColSm b) = ColSm (a+b) -addGO (ColMd a) (ColMd b) = ColMd (a+b) -addGO (ColLg a) (ColLg b) = ColLg (a+b) -addGO a b | a > b = addGO b a -addGO (ColXs a) other = addGO (ColSm a) other -addGO (ColSm a) other = addGO (ColMd a) other -addGO (ColMd a) other = addGO (ColLg a) other -addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here" - - --- | The layout used for the bootstrap form. --- --- Since: yesod-form 1.3.8 -data BootstrapFormLayout = - BootstrapBasicForm - | BootstrapInlineForm - | BootstrapHorizontalForm - { bflLabelOffset :: !BootstrapGridOptions - , bflLabelSize :: !BootstrapGridOptions - , bflInputOffset :: !BootstrapGridOptions - , bflInputSize :: !BootstrapGridOptions - } - deriving (Show) - - --- | Render the given form using Bootstrap v3 conventions. --- --- Sample Hamlet for 'BootstrapHorizontalForm': --- --- >
--- > ^{formWidget} --- > ^{bootstrapSubmit MsgSubmit} --- --- Since: yesod-form 1.3.8 -renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a -renderBootstrap3 formLayout aform fragment = do - (res, views') <- aFormToForm aform - let views = views' [] - has (Just _) = True - has Nothing = False - widget = [whamlet| - #{fragment} - $forall view <- views -
- $case formLayout - $of BootstrapBasicForm - $if nequals (fvId view) bootstrapSubmitId -