diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/WebApp.hs | 158 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 91 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 319 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 204 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 339 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 237 | ||||
| -rw-r--r-- | Assistant/WebApp/Documentation.hs | 23 | ||||
| -rw-r--r-- | Assistant/WebApp/Notifications.hs | 59 | ||||
| -rw-r--r-- | Assistant/WebApp/OtherRepos.hs | 53 | ||||
| -rw-r--r-- | Assistant/WebApp/SideBar.hs | 94 | ||||
| -rw-r--r-- | Assistant/WebApp/Types.hs | 98 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 39 |
12 files changed, 0 insertions, 1714 deletions
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs deleted file mode 100644 index c8eaeecf0..000000000 --- a/Assistant/WebApp.hs +++ /dev/null @@ -1,158 +0,0 @@ -{- git-annex assistant webapp core - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp where - -import Assistant.WebApp.Types -import Assistant.Common -import Assistant.ThreadedMonad -import Assistant.DaemonStatus -import Utility.NotificationBroadcaster -import Utility.Yesod -import Locations.UserConfig - -import Yesod -import Text.Hamlet -import Data.Text (Text) -import Control.Concurrent.STM -import Control.Concurrent - -data NavBarItem = DashBoard | Config | About - deriving (Eq) - -navBarName :: NavBarItem -> Text -navBarName DashBoard = "Dashboard" -navBarName Config = "Configuration" -navBarName About = "About" - -navBarRoute :: NavBarItem -> Route WebApp -navBarRoute DashBoard = HomeR -navBarRoute Config = ConfigR -navBarRoute About = AboutR - -defaultNavBar :: [NavBarItem] -defaultNavBar = [DashBoard, Config, About] - -firstRunNavBar :: [NavBarItem] -firstRunNavBar = [Config, About] - -selectNavBar :: Handler [NavBarItem] -selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar) - -inFirstRun :: Handler Bool -inFirstRun = isNothing . relDir <$> getYesod - -{- Used instead of defaultContent; highlights the current page if it's - - on the navbar. -} -bootstrap :: Maybe NavBarItem -> Widget -> Handler RepHtml -bootstrap navbaritem content = do - webapp <- getYesod - navbar <- map navdetails <$> selectNavBar - page <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css - addStylesheet $ StaticR css_bootstrap_responsive_css - addScript $ StaticR jquery_full_js - addScript $ StaticR js_bootstrap_dropdown_js - addScript $ StaticR js_bootstrap_modal_js - $(widgetFile "page") - hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap") - where - navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem) - -newWebAppState :: IO (TMVar WebAppState) -newWebAppState = do - otherrepos <- listOtherRepos - atomically $ newTMVar $ WebAppState - { showIntro = True - , otherRepos = otherrepos } - -getWebAppState :: forall sub. GHandler sub WebApp WebAppState -getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod - -modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp () -modifyWebAppState a = go =<< webAppState <$> getYesod - where - go s = liftIO $ atomically $ do - v <- takeTMVar s - putTMVar s $ a v - -{- Runs an Annex action from the webapp. - - - - When the webapp is run outside a git-annex repository, the fallback - - value is returned. - -} -runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a -runAnnex fallback a = maybe (return fallback) go =<< threadState <$> getYesod - where - go st = liftIO $ runThreadState st a - -waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp () -waitNotifier selector nid = do - notifier <- getNotifier selector - liftIO $ waitNotification $ notificationHandleFromId notifier nid - -newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId -newNotifier selector = do - notifier <- getNotifier selector - liftIO $ notificationHandleToId <$> newNotificationHandle notifier - -getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster -getNotifier selector = do - webapp <- getYesod - liftIO $ selector <$> getDaemonStatus (daemonStatus webapp) - -{- Adds the auth parameter as a hidden field on a form. Must be put into - - every form. -} -webAppFormAuthToken :: Widget -webAppFormAuthToken = do - webapp <- lift getYesod - [whamlet|<input type="hidden" name="auth" value="#{secretToken webapp}">|] - -{- A button with an icon, and maybe label, that can be clicked to perform - - some action. - - With javascript, clicking it POSTs the Route, and remains on the same - - page. - - With noscript, clicking it GETs the Route. -} -actionButton :: Route WebApp -> (Maybe String) -> String -> String -> Widget -actionButton route label buttonclass iconclass = $(widgetFile "actionbutton") - -type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text -type UrlRenderer = MVar (UrlRenderFunc) - -newUrlRenderer :: IO UrlRenderer -newUrlRenderer = newEmptyMVar - -setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO () -setUrlRenderer = putMVar - -{- Blocks until the webapp is running and has called setUrlRenderer. -} -renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text -renderUrl urlrenderer route params = do - r <- readMVar urlrenderer - return $ r route params - -{- Redirects back to the referring page, or if there's none, HomeR -} -redirectBack :: Handler () -redirectBack = do - clearUltDest - setUltDestReferer - redirectUltDest HomeR - -{- List of other known repsitories, and link to add a new one. -} -otherReposWidget :: Widget -otherReposWidget = do - repolist <- lift $ otherRepos <$> getWebAppState - $(widgetFile "otherrepos") - -listOtherRepos :: IO [(String, String)] -listOtherRepos = do - f <- autoStartFile - dirs <- ifM (doesFileExist f) ( lines <$> readFile f, return []) - names <- mapM relHome dirs - return $ sort $ zip names dirs diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs deleted file mode 100644 index 3f6a3f3e1..000000000 --- a/Assistant/WebApp/Configurators.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- git-annex assistant webapp configurators - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL 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 diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs deleted file mode 100644 index a86d13026..000000000 --- a/Assistant/WebApp/Configurators/Local.hs +++ /dev/null @@ -1,319 +0,0 @@ -{- git-annex assistant webapp configurators for making local repositories - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.Configurators.Local where - -import Assistant.Common -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Assistant.Sync -import Assistant.MakeRemote -import Utility.Yesod -import Init -import qualified Git -import qualified Git.Construct -import qualified Git.Config -import qualified Annex -import Locations.UserConfig -import Utility.FreeDesktop -import Utility.Mounts -import Utility.DiskFree -import Utility.DataUnits -import Utility.Network -import Remote (prettyListUUIDs) - -import Yesod -import Data.Text (Text) -import qualified Data.Text as T -import Data.Char -import System.Posix.Directory -import qualified Control.Exception as E - -data RepositoryPath = RepositoryPath Text - deriving Show - -{- Custom field display for a RepositoryPath, with an icon etc. - - - - Validates that the path entered is not empty, and is a safe value - - to use as a repository. -} -repositoryPathField :: forall sub. Bool -> Field sub WebApp Text -repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view } - where - view idAttr nameAttr attrs val isReq = - [whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|] - - parse [path] - | T.null path = nopath - | otherwise = liftIO $ checkRepositoryPath path - parse [] = return $ Right Nothing - parse _ = nopath - - nopath = return $ Left "Enter a location for the repository" - -{- As well as checking the path for a lot of silly things, tilde is - - expanded in the returned path. -} -checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text)) -checkRepositoryPath p = do - home <- myHomeDir - let basepath = expandTilde home $ T.unpack p - path <- absPath basepath - let parent = parentDir path - problems <- catMaybes <$> mapM runcheck - [ (return $ path == "/", "Enter the full path to use for the repository.") - , (return $ all isSpace basepath, "A blank path? Seems unlikely.") - , (doesFileExist path, "A file already exists with that name.") - , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") - , (not <$> doesDirectoryExist parent, "Parent directory does not exist.") - , (not <$> canWrite path, "Cannot write a repository there.") - , (not <$> canMakeSymlink path, "That directory is on a filesystem that does not support symlinks. Try a different location.") - ] - return $ - case headMaybe problems of - Nothing -> Right $ Just $ T.pack basepath - Just prob -> Left prob - where - runcheck (chk, msg) = ifM (chk) - ( return $ Just msg - , return Nothing - ) - expandTilde home ('~':'/':path) = home </> path - expandTilde _ path = path - - -{- On first run, if run in the home directory, default to putting it in - - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. - - - - If run in another directory, the user probably wants to put it there. -} -defaultRepositoryPath :: Bool -> IO FilePath -defaultRepositoryPath firstrun = do - cwd <- liftIO $ getCurrentDirectory - home <- myHomeDir - if home == cwd && firstrun - then do - desktop <- userDesktopDir - ifM (doesDirectoryExist desktop) - ( relHome $ desktop </> gitAnnexAssistantDefaultDir - , return $ "~" </> gitAnnexAssistantDefaultDir - ) - else return cwd - -newRepositoryForm :: FilePath -> Form RepositoryPath -newRepositoryForm defpath msg = do - (pathRes, pathView) <- mreq (repositoryPathField True) "" - (Just $ T.pack $ addTrailingPathSeparator defpath) - let (err, errmsg) = case pathRes of - FormMissing -> (False, "") - FormFailure l -> (True, concat $ map T.unpack l) - FormSuccess _ -> (False, "") - let form = do - webAppFormAuthToken - $(widgetFile "configurators/newrepository/form") - return (RepositoryPath <$> pathRes, form) - -{- Making the first repository, when starting the webapp for the first time. -} -getFirstRepositoryR :: Handler RepHtml -getFirstRepositoryR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Getting started" - path <- liftIO . defaultRepositoryPath =<< lift inFirstRun - ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path - case res of - FormSuccess (RepositoryPath p) -> lift $ - startFullAssistant $ T.unpack p - _ -> $(widgetFile "configurators/newrepository/first") - -{- Adding a new, separate repository. -} -getNewRepositoryR :: Handler RepHtml -getNewRepositoryR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add another repository" - home <- liftIO myHomeDir - ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home - case res of - FormSuccess (RepositoryPath p) -> lift $ do - let path = T.unpack p - liftIO $ do - makeRepo path False - initRepo path Nothing - addAutoStart path - redirect $ SwitchToRepositoryR path - _ -> $(widgetFile "configurators/newrepository") - -data RemovableDrive = RemovableDrive - { diskFree :: Maybe Integer - , mountPoint :: Text - } - deriving (Show, Eq, Ord) - -selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive -selectDriveForm drives def = renderBootstrap $ RemovableDrive - <$> pure Nothing - <*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def) - where - pairs = zip (map describe drives) (map mountPoint drives) - describe drive = case diskFree drive of - Nothing -> mountPoint drive - Just free -> - let sz = roughSize storageUnits True free - in T.unwords - [ mountPoint drive - , T.concat ["(", T.pack sz] - , "free)" - ] - -{- Adding a removable drive. -} -getAddDriveR :: Handler RepHtml -getAddDriveR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a removable drive" - removabledrives <- liftIO $ driveList - writabledrives <- liftIO $ - filterM (canWrite . T.unpack . mountPoint) removabledrives - ((res, form), enctype) <- lift $ runFormGet $ - selectDriveForm (sort writabledrives) Nothing - case res of - FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do - go $ T.unpack d - redirect RepositoriesR - _ -> do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/adddrive") - where - go mountpoint = do - liftIO $ makerepo dir - liftIO $ initRepo dir $ Just remotename - r <- addremote dir remotename - syncRemote r - where - dir = mountpoint </> gitAnnexAssistantDefaultDir - remotename = takeFileName mountpoint - {- The repo may already exist, when adding removable media - - that has already been used elsewhere. -} - makerepo dir = liftIO $ do - r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool) - case r of - Right _ -> noop - Left _e -> do - createDirectoryIfMissing True dir - bare <- not <$> canMakeSymlink dir - makeRepo dir bare - {- Each repository is made a remote of the other. -} - addremote dir name = runAnnex undefined $ do - hostname <- maybe "host" id <$> liftIO getHostname - hostlocation <- fromRepo Git.repoLocation - liftIO $ inDir dir $ - void $ makeGitRemote hostname hostlocation - addRemote $ makeGitRemote name dir - -getEnableDirectoryR :: UUID -> Handler RepHtml -getEnableDirectoryR uuid = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Enable a repository" - description <- lift $ runAnnex "" $ - T.pack . concat <$> prettyListUUIDs [uuid] - $(widgetFile "configurators/enabledirectory") - -{- Start syncing a newly added remote, using a background thread. -} -syncRemote :: Remote -> Handler () -syncRemote remote = do - webapp <- getYesod - liftIO $ syncNewRemote - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - remote - -{- List of removable drives. -} -driveList :: IO [RemovableDrive] -driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts - where - gen dir = RemovableDrive - <$> getDiskFree dir - <*> pure (T.pack dir) - -- filter out some things that are surely not removable drives - sane Mntent { mnt_dir = dir, mnt_fsname = dev } - {- We want real disks like /dev/foo, not - - dummy mount points like proc or tmpfs or - - gvfs-fuse-daemon. -} - | not ('/' `elem` dev) = False - {- Just in case: These mount points are surely not - - removable disks. -} - | dir == "/" = False - | dir == "/tmp" = False - | dir == "/run/shm" = False - | dir == "/run/lock" = False - | otherwise = True - -{- Bootstraps from first run mode to a fully running assistant in a - - repository, by running the postFirstRun callback, which returns the - - url to the new webapp. -} -startFullAssistant :: FilePath -> Handler () -startFullAssistant path = do - webapp <- getYesod - url <- liftIO $ do - makeRepo path False - initRepo path Nothing - addAutoStart path - changeWorkingDirectory path - fromJust $ postFirstRun webapp - redirect $ T.pack url - -{- Makes a new git-annex repository. -} -makeRepo :: FilePath -> Bool -> IO () -makeRepo path bare = do - unlessM (boolSystem "git" params) $ - error "git init failed!" - where - baseparams = [Param "init", Param "--quiet"] - params - | bare = baseparams ++ [Param "--bare", File path] - | otherwise = baseparams ++ [File path] - -{- Runs an action in the git-annex repository in the specified directory. -} -inDir :: FilePath -> Annex a -> IO a -inDir dir a = do - state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir - Annex.eval state a - -{- Initializes a git-annex repository in a directory with a description. -} -initRepo :: FilePath -> Maybe String -> IO () -initRepo dir desc = inDir dir $ - unlessM isInitialized $ - initialize desc - -{- Adds a directory to the autostart file. -} -addAutoStart :: FilePath -> IO () -addAutoStart path = do - autostart <- autoStartFile - createDirectoryIfMissing True (parentDir autostart) - appendFile autostart $ path ++ "\n" - -{- Checks if the user can write to a directory. - - - - The directory may be in the process of being created; if so - - the parent directory is checked instead. -} -canWrite :: FilePath -> IO Bool -canWrite dir = do - tocheck <- ifM (doesDirectoryExist dir) - (return dir, return $ parentDir dir) - catchBoolIO $ fileAccess tocheck False True False - -{- Checks if a directory is on a filesystem that supports symlinks. -} -canMakeSymlink :: FilePath -> IO Bool -canMakeSymlink dir = ifM (doesDirectoryExist dir) - ( catchBoolIO $ test dir - , canMakeSymlink (parentDir dir) - ) - where - test d = do - let link = d </> "delete.me" - createSymbolicLink link link - removeLink link - return True diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs deleted file mode 100644 index 87353be3c..000000000 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ /dev/null @@ -1,204 +0,0 @@ -{- git-annex assistant webapp configurator for pairing - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} -{-# LANGUAGE CPP #-} - -module Assistant.WebApp.Configurators.Pairing where - -import Assistant.Pairing -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Utility.Yesod -#ifdef WITH_PAIRING -import Assistant.Common -import Assistant.Pairing.Network -import Assistant.Pairing.MakeRemote -import Assistant.Ssh -import Assistant.Alert -import Assistant.DaemonStatus -import Utility.Verifiable -import Utility.Network -import Annex.UUID -#endif - -import Yesod -import Data.Text (Text) -#ifdef WITH_PAIRING -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Lazy as B -import Data.Char -import System.Posix.User -import qualified Control.Exception as E -import Control.Concurrent -#endif - -{- Starts sending out pair requests. -} -getStartPairR :: Handler RepHtml -#ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing -#else -getStartPairR = noPairing -#endif - -{- Runs on the system that responds to a pair request; sets up the ssh - - authorized key first so that the originating host can immediately sync - - with us. -} -getFinishPairR :: PairMsg -> Handler RepHtml -#ifdef WITH_PAIRING -getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do - liftIO $ setup - startPairing PairAck cleanup alert uuid "" secret - where - alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just - setup = setupAuthorizedKeys msg - cleanup = removeAuthorizedKeys False $ - remoteSshPubKey $ pairMsgData msg - uuid = Just $ pairUUID $ pairMsgData msg -#else -getFinishPairR _ = noPairing -#endif - -getInprogressPairR :: SecretReminder -> Handler RepHtml -#ifdef WITH_PAIRING -getInprogressPairR s = pairPage $ do - let secret = fromSecretReminder s - $(widgetFile "configurators/pairing/inprogress") -#else -getInprogressPairR _ = noPairing -#endif - -#ifdef WITH_PAIRING - -{- Starts pairing, at either the PairReq (initiating host) or - - PairAck (responding host) stage. - - - - Displays an alert, and starts a thread sending the pairing message, - - which will continue running until the other host responds, or until - - canceled by the user. If canceled by the user, runs the oncancel action. - - - - Redirects to the pairing in progress page. - -} -startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget -startPairing stage oncancel alert muuid displaysecret secret = do - dstatus <- daemonStatus <$> lift getYesod - urlrender <- lift getUrlRender - reldir <- fromJust . relDir <$> lift getYesod - - {- Generating a ssh key pair can take a while, so do it in the - - background. -} - void $ liftIO $ forkIO $ do - keypair <- genSshKeyPair - pairdata <- PairData - <$> getHostname - <*> getUserName - <*> pure reldir - <*> pure (sshPubKey keypair) - <*> (maybe genUUID return muuid) - let sender = multicastPairMsg Nothing secret pairdata - let pip = PairingInProgress secret Nothing keypair pairdata stage - startSending dstatus pip stage $ sendrequests sender dstatus urlrender - - lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret - where - {- Sends pairing messages until the thread is killed, - - and shows an activity alert while doing it. - - - - The cancel button returns the user to the HomeR. This is - - not ideal, but they have to be sent somewhere, and could - - have been on a page specific to the in-process pairing - - that just stopped, so can't go back there. - -} - sendrequests sender dstatus urlrender _stage = do - tid <- myThreadId - let selfdestruct = AlertButton - { buttonLabel = "Cancel" - , buttonUrl = urlrender HomeR - , buttonAction = Just $ const $ do - oncancel - killThread tid - } - alertDuring dstatus (alert selfdestruct) $ do - _ <- E.try (sender stage) :: IO (Either E.SomeException ()) - return () - -data InputSecret = InputSecret { secretText :: Maybe Text } - -{- If a PairMsg is passed in, ensures that the user enters a secret - - that can validate it. -} -promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml -promptSecret msg cont = pairPage $ do - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ - InputSecret <$> aopt textField "Secret phrase" Nothing - case result of - FormSuccess v -> do - let rawsecret = fromMaybe "" $ secretText v - let secret = toSecret rawsecret - case msg of - Nothing -> case secretProblem secret of - Nothing -> cont rawsecret secret - Just problem -> - showform form enctype $ Just problem - Just m -> - if verify (fromPairMsg m) secret - then cont rawsecret secret - else showform form enctype $ Just - "That's not the right secret phrase." - _ -> showform form enctype Nothing - where - showform form enctype mproblem = do - let start = isNothing msg - let badphrase = isJust mproblem - let problem = fromMaybe "" mproblem - let (username, hostname) = maybe ("", "") - (\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v))) - (verifiableVal . fromPairMsg <$> msg) - u <- T.pack <$> liftIO getUserName - let sameusername = username == u - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/pairing/prompt") - -{- This counts unicode characters as more than one character, - - but that's ok; they *do* provide additional entropy. -} -secretProblem :: Secret -> Maybe Text -secretProblem s - | B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)" - | B.length s < 7 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day." - | s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!" - | otherwise = Nothing - -toSecret :: Text -> Secret -toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s] - -getUserName :: IO String -getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) - -pairPage :: Widget -> Handler RepHtml -pairPage w = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" - w - -{- From Dickens -} -sampleQuote :: Text -sampleQuote = T.unwords - [ "It was the best of times," - , "it was the worst of times," - , "it was the age of wisdom," - , "it was the age of foolishness." - ] - -#else - -noPairing :: Handler RepHtml -noPairing = pairPage $ - $(widgetFile "configurators/pairing/disabled") - -#endif diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs deleted file mode 100644 index 7fba8ff52..000000000 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ /dev/null @@ -1,339 +0,0 @@ -{- git-annex assistant webapp configurator for ssh-based remotes - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.Configurators.Ssh where - -import Assistant.Common -import Assistant.Ssh -import Assistant.MakeRemote -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Utility.Yesod -import Utility.Rsync (rsyncUrlIsShell) -import Logs.Remote -import Remote - -import Yesod -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as M -import Network.BSD -import System.Posix.User - -sshConfigurator :: Widget -> Handler RepHtml -sshConfigurator a = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a remote server" - a - -data SshInput = SshInput - { hostname :: Maybe Text - , username :: Maybe Text - , directory :: Maybe Text - } - deriving (Show) - -{- SshInput is only used for applicative form prompting, this converts - - the result of such a form into a SshData. -} -mkSshData :: SshInput -> SshData -mkSshData s = SshData - { sshHostName = fromMaybe "" $ hostname s - , sshUserName = username s - , sshDirectory = fromMaybe "" $ directory s - , sshRepoName = genSshRepoName - (T.unpack $ fromJust $ hostname s) - (maybe "" T.unpack $ directory s) - , needsPubKey = False - , rsyncOnly = False - } - -sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput -sshInputAForm def = SshInput - <$> aopt check_hostname "Host name" (Just $ hostname def) - <*> aopt check_username "User name" (Just $ username def) - <*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def) - where - check_hostname = checkM (liftIO . checkdns) textField - checkdns t = do - let h = T.unpack t - r <- catchMaybeIO $ getHostByName h - return $ case r of - -- canonicalize input hostname if it had no dot - Just hostentry - | '.' `elem` h -> Right t - | otherwise -> Right $ T.pack $ hostName hostentry - Nothing -> Left bad_hostname - - check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack) - bad_username textField - - bad_hostname = "cannot resolve host name" :: Text - bad_username = "bad user name" :: Text - -data ServerStatus - = UntestedServer - | UnusableServer Text -- reason why it's not usable - | UsableRsyncServer - | UsableSshInput - deriving (Eq) - -usable :: ServerStatus -> Bool -usable UntestedServer = False -usable (UnusableServer _) = False -usable UsableRsyncServer = True -usable UsableSshInput = True - -getAddSshR :: Handler RepHtml -getAddSshR = sshConfigurator $ do - u <- liftIO $ T.pack . userName - <$> (getUserEntryForID =<< getEffectiveUserID) - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ sshInputAForm $ - SshInput Nothing (Just u) Nothing - case result of - FormSuccess sshinput -> do - s <- liftIO $ testServer sshinput - case s of - Left status -> showform form enctype status - Right sshdata -> lift $ redirect $ ConfirmSshR sshdata - _ -> showform form enctype UntestedServer - where - showform form enctype status = do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/add") - -{- To enable an existing rsync special remote, parse the SshInput from - - its rsyncurl, and display a form whose only real purpose is to check - - if ssh public keys need to be set up. From there, we can proceed with - - the usual repo setup; all that code is idempotent. - - - - Note that there's no EnableSshR because ssh remotes are not special - - remotes, and so their configuration is not shared between repositories. - -} -getEnableRsyncR :: UUID -> Handler RepHtml -getEnableRsyncR u = do - m <- runAnnex M.empty readRemoteLog - case parseSshRsyncUrl =<< M.lookup "rsyncurl" =<< M.lookup u m of - Nothing -> redirect AddSshR - Just sshinput -> sshConfigurator $ do - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ sshInputAForm sshinput - case result of - FormSuccess sshinput' - | isRsyncNet (hostname sshinput') -> - void $ lift $ makeRsyncNet sshinput' - | otherwise -> do - s <- liftIO $ testServer sshinput' - case s of - Left status -> showform form enctype status - Right sshdata -> enable sshdata - _ -> showform form enctype UntestedServer - where - showform form enctype status = do - description <- lift $ runAnnex "" $ - T.pack . concat <$> prettyListUUIDs [u] - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/enable") - enable sshdata = - lift $ redirect $ ConfirmSshR $ - sshdata { rsyncOnly = True } - -{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync - - url; rsync:// urls or bare path names are not supported. - - - - The hostname is stored mangled in the remote log for rsync special - - remotes configured by this webapp. So that mangling has to reversed - - here to get back the original hostname. - -} -parseSshRsyncUrl :: String -> Maybe SshInput -parseSshRsyncUrl u - | not (rsyncUrlIsShell u) = Nothing - | otherwise = Just $ SshInput - { hostname = val $ unMangleSshHostName host - , username = if null user then Nothing else val user - , directory = val dir - } - where - val = Just . T.pack - (userhost, dir) = separate (== ':') u - (user, host) = if '@' `elem` userhost - then separate (== '@') userhost - else (userhost, "") - -{- Test if we can ssh into the server. - - - - Two probe attempts are made. First, try sshing in using the existing - - configuration, but don't let ssh prompt for any password. If - - passwordless login is already enabled, use it. Otherwise, - - a special ssh key will need to be generated just for this server. - - - - Once logged into the server, probe to see if git-annex-shell is - - available, or rsync. - -} -testServer :: SshInput -> IO (Either ServerStatus SshData) -testServer (SshInput { hostname = Nothing }) = return $ - Left $ UnusableServer "Please enter a host name." -testServer sshinput@(SshInput { hostname = Just hn }) = do - status <- probe [sshOpt "NumberOfPasswordPrompts" "0"] - if usable status - then ret status False - else do - status' <- probe [] - if usable status' - then ret status' True - else return $ Left status' - where - ret status needspubkey = return $ Right $ - (mkSshData sshinput) - { needsPubKey = needspubkey - , rsyncOnly = status == UsableRsyncServer - } - probe extraopts = do - let remotecommand = join ";" - [ report "loggedin" - , checkcommand "git-annex-shell" - , checkcommand "rsync" - ] - knownhost <- knownHost hn - let sshopts = filter (not . null) $ extraopts ++ - {- If this is an already known host, let - - ssh check it as usual. - - Otherwise, trust the host key. -} - [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no" - , "-n" -- don't read from stdin - , genSshHost (fromJust $ hostname sshinput) (username sshinput) - , remotecommand - ] - parsetranscript . fst <$> sshTranscript sshopts "" - parsetranscript s - | reported "git-annex-shell" = UsableSshInput - | reported "rsync" = UsableRsyncServer - | reported "loggedin" = UnusableServer - "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?" - | otherwise = UnusableServer $ T.pack $ - "Failed to ssh to the server. Transcript: " ++ s - where - reported r = token r `isInfixOf` s - checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" - token r = "git-annex-probe " ++ r - report r = "echo " ++ token r - -{- Runs a ssh command; if it fails shows the user the transcript, - - and if it succeeds, runs an action. -} -sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml -sshSetup opts input a = do - (transcript, ok) <- liftIO $ sshTranscript opts input - if ok - then a - else showSshErr transcript - -showSshErr :: String -> Handler RepHtml -showSshErr msg = sshConfigurator $ - $(widgetFile "configurators/ssh/error") - -getConfirmSshR :: SshData -> Handler RepHtml -getConfirmSshR sshdata = sshConfigurator $ do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/confirm") - -getMakeSshGitR :: SshData -> Handler RepHtml -getMakeSshGitR = makeSsh False - -getMakeSshRsyncR :: SshData -> Handler RepHtml -getMakeSshRsyncR = makeSsh True - -makeSsh :: Bool -> SshData -> Handler RepHtml -makeSsh rsync sshdata - | needsPubKey sshdata = do - keypair <- liftIO genSshKeyPair - sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSsh' rsync sshdata' (Just keypair) - | otherwise = makeSsh' rsync sshdata Nothing - -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSsh' rsync sshdata keypair = - sshSetup [sshhost, remoteCommand] "" $ - makeSshRepo rsync sshdata - where - sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) - remotedir = T.unpack $ sshDirectory sshdata - remoteCommand = join "&&" $ catMaybes - [ Just $ "mkdir -p " ++ shellEscape remotedir - , Just $ "cd " ++ shellEscape remotedir - , if rsync then Nothing else Just "git init --bare --shared" - , if rsync then Nothing else Just "git annex init" - , if needsPubKey sshdata - then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair - else Nothing - ] - -makeSshRepo :: Bool -> SshData -> Handler RepHtml -makeSshRepo forcersync sshdata = do - webapp <- getYesod - liftIO $ makeSshRemote - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - forcersync sshdata - redirect RepositoriesR - -getAddRsyncNetR :: Handler RepHtml -getAddRsyncNetR = do - ((result, form), enctype) <- runFormGet $ - renderBootstrap $ sshInputAForm $ - SshInput Nothing Nothing Nothing - let showform status = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a Rsync.net repository" - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/addrsync.net") - case result of - FormSuccess sshinput - | isRsyncNet (hostname sshinput) -> - makeRsyncNet sshinput - | otherwise -> - showform $ UnusableServer - "That is not a rsync.net host name." - _ -> showform UntestedServer - -makeRsyncNet :: SshInput -> Handler RepHtml -makeRsyncNet sshinput = do - knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput) - keypair <- liftIO $ genSshKeyPair - sshdata <- liftIO $ setupSshKeyPair keypair $ - (mkSshData sshinput) - { sshRepoName = "rsync.net" - , needsPubKey = True - , rsyncOnly = True - } - {- I'd prefer to separate commands with && , but - - rsync.net's shell does not support that. - - - - The dd method of appending to the authorized_keys file is the - - one recommended by rsync.net documentation. I touch the file first - - to not need to use a different method to create it. - -} - let remotecommand = join ";" - [ "mkdir -p .ssh" - , "touch .ssh/authorized_keys" - , "dd of=.ssh/authorized_keys oflag=append conv=notrunc" - , "mkdir -p " ++ T.unpack (sshDirectory sshdata) - ] - let sshopts = filter (not . null) - [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no" - , genSshHost (sshHostName sshdata) (sshUserName sshdata) - , remotecommand - ] - sshSetup sshopts (sshPubKey keypair) $ - makeSshRepo True sshdata - -isRsyncNet :: Maybe Text -> Bool -isRsyncNet Nothing = False -isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs deleted file mode 100644 index fc6b8ea1b..000000000 --- a/Assistant/WebApp/DashBoard.hs +++ /dev/null @@ -1,237 +0,0 @@ -{- git-annex assistant webapp dashboard - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.DashBoard where - -import Assistant.Common -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Assistant.WebApp.Notifications -import Assistant.WebApp.Configurators -import Assistant.DaemonStatus -import Assistant.TransferQueue -import Assistant.TransferSlots -import qualified Assistant.Threads.Transferrer as Transferrer -import Utility.NotificationBroadcaster -import Utility.Yesod -import Logs.Transfer -import Utility.Percentage -import Utility.DataUnits -import Types.Key -import qualified Remote -import qualified Git -import Locations.UserConfig - -import Yesod -import Text.Hamlet -import qualified Data.Map as M -import Control.Concurrent -import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) -import System.Posix.Process (getProcessGroupIDOf) - -{- A display of currently running and queued transfers. - - - - Or, if there have never been any this run, an intro display. -} -transfersDisplay :: Bool -> Widget -transfersDisplay warnNoScript = do - webapp <- lift getYesod - current <- lift $ M.toList <$> getCurrentTransfers - queued <- liftIO $ getTransferQueue $ transferQueue webapp - let ident = "transfers" - autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int) - let transfers = simplifyTransfers $ current ++ queued - if null transfers - then ifM (lift $ showIntro <$> getWebAppState) - ( introDisplay ident - , $(widgetFile "dashboard/transfers") - ) - else $(widgetFile "dashboard/transfers") - where - isrunning info = not $ - transferPaused info || isNothing (startedTime info) - -{- Simplifies a list of transfers, avoiding display of redundant - - equivilant transfers. -} -simplifyTransfers :: [(Transfer, TransferInfo)] -> [(Transfer, TransferInfo)] -simplifyTransfers [] = [] -simplifyTransfers (x:[]) = [x] -simplifyTransfers (v@(t1, _):r@((t2, _):l)) - | equivilantTransfer t1 t2 = simplifyTransfers (v:l) - | otherwise = v : (simplifyTransfers r) - -{- Called by client to get a display of currently in process transfers. - - - - Returns a div, which will be inserted into the calling page. - - - - Note that the head of the widget is not included, only its - - body is. To get the widget head content, the widget is also - - inserted onto the getHomeR page. - -} -getTransfersR :: NotificationId -> Handler RepHtml -getTransfersR nid = do - waitNotifier transferNotifier nid - - page <- widgetToPageContent $ transfersDisplay False - hamletToRepHtml $ [hamlet|^{pageBody page}|] - -{- The main dashboard. -} -dashboard :: Bool -> Widget -dashboard warnNoScript = do - sideBarDisplay - let content = transfersDisplay warnNoScript - $(widgetFile "dashboard/main") - -getHomeR :: Handler RepHtml -getHomeR = ifM (inFirstRun) - ( redirect ConfigR - , bootstrap (Just DashBoard) $ dashboard True - ) - -{- Used to test if the webapp is running. -} -headHomeR :: Handler () -headHomeR = noop - -{- Same as HomeR, except no autorefresh at all (and no noscript warning). -} -getNoScriptR :: Handler RepHtml -getNoScriptR = bootstrap (Just DashBoard) $ dashboard False - -{- Same as HomeR, except with autorefreshing via meta refresh. -} -getNoScriptAutoR :: Handler RepHtml -getNoScriptAutoR = bootstrap (Just DashBoard) $ do - let ident = NoScriptR - let delayseconds = 3 :: Int - let this = NoScriptAutoR - toWidgetHead $(hamletFile $ hamletTemplate "dashboard/metarefresh") - dashboard False - -{- The javascript code does a post. -} -postFileBrowserR :: Handler () -postFileBrowserR = void openFileBrowser - -{- Used by non-javascript browsers, where clicking on the link actually - - opens this page, so we redirect back to the referrer. -} -getFileBrowserR :: Handler () -getFileBrowserR = whenM openFileBrowser $ redirectBack - -{- Opens the system file browser on the repo, or, as a fallback, - - goes to a file:// url. Returns True if it's ok to redirect away - - from the page (ie, the system file browser was opened). - - - - Note that the command is opened using a different thread, to avoid - - blocking the response to the browser on it. -} -openFileBrowser :: Handler Bool -openFileBrowser = do - path <- runAnnex (error "no configured repository") $ - fromRepo Git.repoPath - ifM (liftIO $ inPath cmd <&&> inPath cmd) - ( do - void $ liftIO $ forkIO $ void $ - boolSystem cmd [Param path] - return True - , do - clearUltDest - setUltDest $ "file://" ++ path - void $ redirectUltDest HomeR - return False - ) - where -#if OSX - cmd = "open" -#else - cmd = "xdg-open" -#endif - -{- Transfer controls. The GET is done in noscript mode and redirects back - - to the referring page. The POST is called by javascript. -} -getPauseTransferR :: Transfer -> Handler () -getPauseTransferR t = pauseTransfer t >> redirectBack -postPauseTransferR :: Transfer -> Handler () -postPauseTransferR t = pauseTransfer t -getStartTransferR :: Transfer -> Handler () -getStartTransferR t = startTransfer t >> redirectBack -postStartTransferR :: Transfer -> Handler () -postStartTransferR t = startTransfer t -getCancelTransferR :: Transfer -> Handler () -getCancelTransferR t = cancelTransfer False t >> redirectBack -postCancelTransferR :: Transfer -> Handler () -postCancelTransferR t = cancelTransfer False t - -pauseTransfer :: Transfer -> Handler () -pauseTransfer = cancelTransfer True - -cancelTransfer :: Bool -> Transfer-> Handler () -cancelTransfer pause t = do - webapp <- getYesod - let dstatus = daemonStatus webapp - m <- getCurrentTransfers - liftIO $ do - unless pause $ - {- remove queued transfer -} - void $ dequeueTransfers (transferQueue webapp) dstatus $ - equivilantTransfer t - {- stop running transfer -} - maybe noop (stop dstatus) (M.lookup t m) - where - stop dstatus info = do - {- When there's a thread associated with the - - transfer, it's signaled first, to avoid it - - displaying any alert about the transfer having - - failed when the transfer process is killed. -} - maybe noop signalthread $ transferTid info - maybe noop killproc $ transferPid info - if pause - then void $ - alterTransferInfo dstatus t $ \i -> i - { transferPaused = True } - else void $ - removeTransfer dstatus t - signalthread tid - | pause = throwTo tid PauseTransfer - | otherwise = killThread tid - {- In order to stop helper processes like rsync, - - kill the whole process group of the process running the - - transfer. -} - killproc pid = do - g <- getProcessGroupIDOf pid - void $ tryIO $ signalProcessGroup sigTERM g - threadDelay 50000 -- 0.05 second grace period - void $ tryIO $ signalProcessGroup sigKILL g - -startTransfer :: Transfer -> Handler () -startTransfer t = do - m <- getCurrentTransfers - maybe startqueued go (M.lookup t m) - where - go info = maybe (start info) resume $ transferTid info - startqueued = do - webapp <- getYesod - let dstatus = daemonStatus webapp - let q = transferQueue webapp - is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t) - maybe noop start $ headMaybe is - resume tid = do - webapp <- getYesod - let dstatus = daemonStatus webapp - liftIO $ do - alterTransferInfo dstatus t $ \i -> i - { transferPaused = False } - throwTo tid ResumeTransfer - start info = do - webapp <- getYesod - let st = fromJust $ threadState webapp - let dstatus = daemonStatus webapp - let slots = transferSlots webapp - liftIO $ inImmediateTransferSlot dstatus slots $ do - program <- readProgramFile - Transferrer.startTransfer st dstatus program t info - -getCurrentTransfers :: Handler TransferMap -getCurrentTransfers = currentTransfers - <$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs deleted file mode 100644 index 3fc0f2374..000000000 --- a/Assistant/WebApp/Documentation.hs +++ /dev/null @@ -1,23 +0,0 @@ -{- git-annex assistant webapp documentation - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.Documentation where - -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Utility.Yesod - -import Yesod - -getAboutR :: Handler RepHtml -getAboutR = bootstrap (Just About) $ do - sideBarDisplay - setTitle "About git-annex" - $(widgetFile "documentation/about") diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs deleted file mode 100644 index 0ef890f68..000000000 --- a/Assistant/WebApp/Notifications.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- git-annex assistant webapp notifications - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.Notifications where - -import Assistant.Common -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.DaemonStatus -import Utility.NotificationBroadcaster -import Utility.Yesod - -import Yesod -import Data.Text (Text) -import qualified Data.Text as T - -{- Add to any widget to make it auto-update using long polling. - - - - The widget should have a html element with an id=ident, which will be - - replaced when it's updated. - - - - The geturl route should return the notifier url to use for polling. - - - - ms_delay is how long to delay between AJAX updates - - ms_startdelay is how long to delay before updating with AJAX at the start - -} -autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget -autoUpdate ident geturl ms_delay ms_startdelay = do - let delay = show ms_delay - let startdelay = show ms_startdelay - addScript $ StaticR longpolling_js - $(widgetFile "notifications/longpolling") - -{- Notifier urls are requested by the javascript, to avoid allocation - - of NotificationIds when noscript pages are loaded. This constructs a - - notifier url for a given Route and NotificationBroadcaster. - -} -notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain -notifierUrl route selector = do - (urlbits, _params) <- renderRoute . route <$> newNotifier selector - webapp <- getYesod - return $ RepPlain $ toContent $ T.concat - [ "/" - , T.intercalate "/" urlbits - , "?auth=" - , secretToken webapp - ] - -getNotifierTransfersR :: Handler RepPlain -getNotifierTransfersR = notifierUrl TransfersR transferNotifier - -getNotifierSideBarR :: Handler RepPlain -getNotifierSideBarR = notifierUrl SideBarR alertNotifier diff --git a/Assistant/WebApp/OtherRepos.hs b/Assistant/WebApp/OtherRepos.hs deleted file mode 100644 index 0c429d182..000000000 --- a/Assistant/WebApp/OtherRepos.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- git-annex assistant webapp switching to other repos - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.OtherRepos where - -import Assistant.Common -import Assistant.WebApp.Types -import qualified Git.Construct -import qualified Git.Config -import Locations.UserConfig -import qualified Utility.Url as Url - -import Yesod -import Control.Concurrent -import System.Process (cwd) - -{- Starts up the assistant in the repository, and waits for it to create - - a gitAnnexUrlFile. Waits for the assistant to be up and listening for - - connections by testing the url. Once it's running, redirect to it. - -} -getSwitchToRepositoryR :: FilePath -> Handler RepHtml -getSwitchToRepositoryR repo = do - liftIO startassistant - url <- liftIO geturl - redirect url - where - startassistant = do - program <- readProgramFile - void $ forkIO $ void $ createProcess $ - (proc program ["assistant"]) - { cwd = Just repo } - geturl = do - r <- Git.Config.read =<< Git.Construct.fromPath repo - waiturl $ gitAnnexUrlFile r - waiturl urlfile = do - v <- tryIO $ readFile urlfile - case v of - Left _ -> delayed $ waiturl urlfile - Right url -> ifM (listening url) - ( return url - , delayed $ waiturl urlfile - ) - listening url = catchBoolIO $ - fst <$> Url.exists url [] - delayed a = do - threadDelay 100000 -- 1/10th of a second - a diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs deleted file mode 100644 index 2a0073319..000000000 --- a/Assistant/WebApp/SideBar.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- git-annex assistant webapp sidebar - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.SideBar where - -import Assistant.Common -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.Notifications -import Assistant.DaemonStatus -import Assistant.Alert -import Utility.NotificationBroadcaster -import Utility.Yesod - -import Yesod -import Data.Text (Text) -import qualified Data.Map as M -import Control.Concurrent - -sideBarDisplay :: Widget -sideBarDisplay = do - let content = do - {- Add newest alerts to the sidebar. -} - webapp <- lift getYesod - alertpairs <- M.toList . alertMap - <$> liftIO (getDaemonStatus $ daemonStatus webapp) - mapM_ renderalert $ - take displayAlerts $ reverse $ sortAlertPairs alertpairs - let ident = "sidebar" - $(widgetFile "sidebar/main") - autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int) - where - bootstrapclass :: AlertClass -> Text - bootstrapclass Activity = "alert-info" - bootstrapclass Warning = "alert" - bootstrapclass Error = "alert-error" - bootstrapclass Success = "alert-success" - bootstrapclass Message = "alert-info" - - renderalert (aid, alert) = do - let alertid = show aid - let closable = alertClosable alert - let block = alertBlockDisplay alert - let divclass = bootstrapclass $ alertClass alert - $(widgetFile "sidebar/alert") - -{- Called by client to get a sidebar display. - - - - Returns a div, which will be inserted into the calling page. - - - - Note that the head of the widget is not included, only its - - body is. To get the widget head content, the widget is also - - inserted onto all pages. - -} -getSideBarR :: NotificationId -> Handler RepHtml -getSideBarR nid = do - waitNotifier alertNotifier nid - - {- This 0.1 second delay avoids very transient notifications from - - being displayed and churning the sidebar unnecesarily. - - - - This needs to be below the level perceptable by the user, - - to avoid slowing down user actions like closing alerts. -} - liftIO $ threadDelay 100000 - - page <- widgetToPageContent sideBarDisplay - hamletToRepHtml $ [hamlet|^{pageBody page}|] - -{- Called by the client to close an alert. -} -getCloseAlert :: AlertId -> Handler () -getCloseAlert i = do - webapp <- getYesod - liftIO $ removeAlert (daemonStatus webapp) i - -{- When an alert with a button is clicked on, the button takes us here. -} -getClickAlert :: AlertId -> Handler () -getClickAlert i = do - webapp <- getYesod - m <- alertMap <$> liftIO (getDaemonStatus $ daemonStatus webapp) - case M.lookup i m of - Just (Alert { alertButton = Just b }) -> do - {- Spawn a thread to run the action while redirecting. -} - case buttonAction b of - Nothing -> noop - Just a -> liftIO $ void $ forkIO $ a i - redirect $ buttonUrl b - _ -> redirectBack - diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs deleted file mode 100644 index 4198cd428..000000000 --- a/Assistant/WebApp/Types.hs +++ /dev/null @@ -1,98 +0,0 @@ -{- git-annex assistant webapp types - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Assistant.WebApp.Types where - -import Assistant.Common -import Assistant.Ssh -import Assistant.ThreadedMonad -import Assistant.DaemonStatus -import Assistant.ScanRemotes -import Assistant.TransferQueue -import Assistant.TransferSlots -import Assistant.Alert -import Assistant.Pairing -import Utility.NotificationBroadcaster -import Utility.WebApp -import Logs.Transfer - -import Yesod -import Yesod.Static -import Data.Text (Text, pack, unpack) -import Control.Concurrent.STM - -staticFiles "static" - -mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") - -data WebApp = WebApp - { threadState :: Maybe ThreadState - , daemonStatus :: DaemonStatusHandle - , scanRemotes :: ScanRemoteMap - , transferQueue :: TransferQueue - , transferSlots :: TransferSlots - , secretToken :: Text - , relDir :: Maybe FilePath - , getStatic :: Static - , webAppState :: TMVar WebAppState - , postFirstRun :: Maybe (IO String) - } - -instance Yesod WebApp where - {- Require an auth token be set when accessing any (non-static route) -} - isAuthorized _ _ = checkAuthToken secretToken - - {- Add the auth token to every url generated, except static subsite - - urls (which can show up in Permission Denied pages). -} - joinPath = insertAuthToken secretToken excludeStatic - where - excludeStatic [] = True - excludeStatic (p:_) = p /= "static" - - makeSessionBackend = webAppSessionBackend - jsLoader _ = BottomOfHeadBlocking - -instance RenderMessage WebApp FormMessage where - renderMessage _ _ = defaultFormMessage - -type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget) - -data WebAppState = WebAppState - { showIntro :: Bool -- should the into message be displayed? - , otherRepos :: [(String, String)] -- name and path to other repos - } - -instance PathPiece SshData where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece NotificationId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece AlertId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece Transfer where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece PairMsg where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece SecretReminder where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece UUID where - toPathPiece = pack . show - fromPathPiece = readish . unpack diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes deleted file mode 100644 index d26e0c567..000000000 --- a/Assistant/WebApp/routes +++ /dev/null @@ -1,39 +0,0 @@ -/ HomeR GET HEAD -/noscript NoScriptR GET -/noscript/auto NoScriptAutoR GET -/about AboutR GET - -/config ConfigR GET -/config/repository RepositoriesR GET - -/config/repository/new/first FirstRepositoryR GET -/config/repository/new NewRepositoryR GET -/config/repository/switchto/#FilePath SwitchToRepositoryR GET - -/config/repository/add/drive AddDriveR GET -/config/repository/add/ssh AddSshR GET -/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET -/config/repository/add/ssh/make/git/#SshData MakeSshGitR GET -/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET -/config/repository/add/rsync.net AddRsyncNetR GET - -/config/repository/pair/start StartPairR GET -/config/repository/pair/inprogress/#SecretReminder InprogressPairR GET -/config/repository/pair/finish/#PairMsg FinishPairR GET - -/config/repository/enable/rsync/#UUID EnableRsyncR GET -/config/repository/enable/directory/#UUID EnableDirectoryR GET - -/transfers/#NotificationId TransfersR GET -/sidebar/#NotificationId SideBarR GET -/notifier/transfers NotifierTransfersR GET -/notifier/sidebar NotifierSideBarR GET -/alert/close/#AlertId CloseAlert GET -/alert/click/#AlertId ClickAlert GET -/filebrowser FileBrowserR GET POST - -/transfer/pause/#Transfer PauseTransferR GET POST -/transfer/start/#Transfer StartTransferR GET POST -/transfer/cancel/#Transfer CancelTransferR GET POST - -/static StaticR Static getStatic |