cb3c9340f8
This means that anyone serving up the webapp to users as a service (ie, without providing any git-annex binary at all to the user) still needs to provide a link to the source code for it, including any modifications they may make. This may make git-annex be covered by the AGPL as a whole when it is built with the webapp. If in doubt, you should ask a lawyer. When git-annex is built with the webapp disabled, no AGPLed code is used. Even building in the assistant does not pull in AGPLed code.
91 lines
2.7 KiB
Haskell
91 lines
2.7 KiB
Haskell
{- git-annex assistant webapp configurators
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
|
|
|
module Assistant.WebApp.Configurators where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.SideBar
|
|
import Assistant.DaemonStatus
|
|
import Assistant.WebApp.Configurators.Local
|
|
import Utility.Yesod
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import Annex.UUID (getUUID)
|
|
import Logs.Remote
|
|
import Logs.Trust
|
|
|
|
import Yesod
|
|
import Data.Text (Text)
|
|
import qualified Data.Map as M
|
|
|
|
{- The main configuration screen. -}
|
|
getConfigR :: Handler RepHtml
|
|
getConfigR = ifM (inFirstRun)
|
|
( getFirstRepositoryR
|
|
, bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Configuration"
|
|
$(widgetFile "configurators/main")
|
|
)
|
|
|
|
{- Lists known repositories, followed by options to add more. -}
|
|
getRepositoriesR :: Handler RepHtml
|
|
getRepositoriesR = bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Repositories"
|
|
repolist <- lift $ repoList False
|
|
$(widgetFile "configurators/repositories")
|
|
|
|
{- A numbered list of known repositories, including the current one. -}
|
|
repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))]
|
|
repoList onlyconfigured
|
|
| onlyconfigured = list =<< configured
|
|
| otherwise = list =<< (++) <$> configured <*> unconfigured
|
|
where
|
|
configured = do
|
|
rs <- filter (not . Remote.readonly) . knownRemotes <$>
|
|
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
|
|
runAnnex [] $ do
|
|
u <- getUUID
|
|
return $ zip (u : map Remote.uuid rs) (repeat Nothing)
|
|
unconfigured = runAnnex [] $ do
|
|
m <- readRemoteLog
|
|
catMaybes . map (findtype m) . snd
|
|
<$> (trustPartition DeadTrusted $ M.keys m)
|
|
findtype m u = case M.lookup u m of
|
|
Nothing -> Nothing
|
|
Just c -> case M.lookup "type" c of
|
|
Just "rsync" -> u `enableswith` EnableRsyncR
|
|
Just "directory" -> u `enableswith` EnableDirectoryR
|
|
_ -> Nothing
|
|
u `enableswith` r = Just (u, Just $ r u)
|
|
list l = runAnnex [] $ do
|
|
let l' = nubBy (\x y -> fst x == fst y) l
|
|
zip3
|
|
<$> pure counter
|
|
<*> Remote.prettyListUUIDs (map fst l')
|
|
<*> pure (map snd l')
|
|
counter = map show ([1..] :: [Int])
|
|
|
|
{- An intro message, list of repositories, and nudge to make more. -}
|
|
introDisplay :: Text -> Widget
|
|
introDisplay ident = do
|
|
webapp <- lift getYesod
|
|
repolist <- lift $ repoList True
|
|
let n = length repolist
|
|
let numrepos = show n
|
|
let notenough = n < enough
|
|
let barelyenough = n == enough
|
|
let morethanenough = n > enough
|
|
$(widgetFile "configurators/intro")
|
|
lift $ modifyWebAppState $ \s -> s { showIntro = False }
|
|
where
|
|
enough = 2
|