mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

clean up build warnings with yesod 1.2, while still building with 1.1

Browse source
This commit is contained in:
Joey Hess 2013-06-27 01:15:28 -04:00
parent b44c978e2c
commit ff4f008591
23 changed files with 149 additions and 137 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Assistant/WebApp.hs
View file

@ -15,7 +15,6 @@ import Assistant.Common
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Yesod import Utility.Yesod
import Yesod
import Data.Text (Text) import Data.Text (Text)
import Control.Concurrent import Control.Concurrent
import qualified Network.Wai as W import qualified Network.Wai as W

3
Assistant/WebApp/Common.hs
View file

@ -12,7 +12,6 @@ import Assistant.WebApp as X
import Assistant.WebApp.Page as X import Assistant.WebApp.Page as X
import Assistant.WebApp.Form as X import Assistant.WebApp.Form as X
import Assistant.WebApp.Types as X import Assistant.WebApp.Types as X
import Utility.Yesod as X import Utility.Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
import Data.Text as X (Text) import Data.Text as X (Text)
import Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)

4
Assistant/WebApp/Configurators.hs
View file

@ -16,7 +16,7 @@ import Assistant.XMPP.Client
#endif #endif
{- The main configuration screen. -} {- The main configuration screen. -}
getConfigurationR :: Handler RepHtml getConfigurationR :: Handler Html
getConfigurationR = ifM (inFirstRun) getConfigurationR = ifM (inFirstRun)
( redirect FirstRepositoryR ( redirect FirstRepositoryR
, page "Configuration" (Just Configuration) $ do , page "Configuration" (Just Configuration) $ do
@ -28,7 +28,7 @@ getConfigurationR = ifM (inFirstRun)
$(widgetFile "configurators/main") $(widgetFile "configurators/main")
) )
getAddRepositoryR :: Handler RepHtml getAddRepositoryR :: Handler Html
getAddRepositoryR = page "Add Repository" (Just Configuration) $ do getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
let repolist = repoListDisplay mainRepoSelector let repolist = repoListDisplay mainRepoSelector
$(widgetFile "configurators/addrepository") $(widgetFile "configurators/addrepository")

20
Assistant/WebApp/Configurators/AWS.hs
View file

@ -29,10 +29,10 @@ import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
awsConfigurator :: Widget -> Handler RepHtml awsConfigurator :: Widget -> Handler Html
awsConfigurator = page "Add an Amazon repository" (Just Configuration) awsConfigurator = page "Add an Amazon repository" (Just Configuration)
glacierConfigurator :: Widget -> Handler RepHtml glacierConfigurator :: Widget -> Handler Html
glacierConfigurator a = do glacierConfigurator a = do
ifM (liftIO $ inPath "glacier") ifM (liftIO $ inPath "glacier")
( awsConfigurator a ( awsConfigurator a
@ -112,10 +112,10 @@ datacenterField service = areq (selectFieldList list) "Datacenter" defregion
list = M.toList $ AWS.regionMap service list = M.toList $ AWS.regionMap service
defregion = Just $ AWS.defaultRegion service defregion = Just $ AWS.defaultRegion service
getAddS3R :: Handler RepHtml getAddS3R :: Handler Html
getAddS3R = postAddS3R getAddS3R = postAddS3R
postAddS3R :: Handler RepHtml postAddS3R :: Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
postAddS3R = awsConfigurator $ do postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
@ -138,10 +138,10 @@ postAddS3R = awsConfigurator $ do
postAddS3R = error "S3 not supported by this build" postAddS3R = error "S3 not supported by this build"
#endif #endif
getAddGlacierR :: Handler RepHtml getAddGlacierR :: Handler Html
getAddGlacierR = postAddGlacierR getAddGlacierR = postAddGlacierR
postAddGlacierR :: Handler RepHtml postAddGlacierR :: Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
postAddGlacierR = glacierConfigurator $ do postAddGlacierR = glacierConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
@ -163,7 +163,7 @@ postAddGlacierR = glacierConfigurator $ do
postAddGlacierR = error "S3 not supported by this build" postAddGlacierR = error "S3 not supported by this build"
#endif #endif
getEnableS3R :: UUID -> Handler RepHtml getEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
getEnableS3R uuid = do getEnableS3R uuid = do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog
@ -174,17 +174,17 @@ getEnableS3R uuid = do
getEnableS3R = postEnableS3R getEnableS3R = postEnableS3R
#endif #endif
postEnableS3R :: UUID -> Handler RepHtml postEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
#else #else
postEnableS3R _ = error "S3 not supported by this build" postEnableS3R _ = error "S3 not supported by this build"
#endif #endif
getEnableGlacierR :: UUID -> Handler RepHtml getEnableGlacierR :: UUID -> Handler Html
getEnableGlacierR = postEnableGlacierR getEnableGlacierR = postEnableGlacierR
postEnableGlacierR :: UUID -> Handler RepHtml postEnableGlacierR :: UUID -> Handler Html
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
enableAWSRemote :: RemoteType -> UUID -> Widget enableAWSRemote :: RemoteType -> UUID -> Widget

20
Assistant/WebApp/Configurators/Delete.hs
View file

@ -28,24 +28,24 @@ import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import System.Path import System.Path
notCurrentRepo :: UUID -> Handler RepHtml -> Handler RepHtml notCurrentRepo :: UUID -> Handler Html -> Handler Html
notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid) notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)
where where
go Nothing = redirect DeleteCurrentRepositoryR go Nothing = redirect DeleteCurrentRepositoryR
go (Just _) = a go (Just _) = a
getDisableRepositoryR :: UUID -> Handler RepHtml getDisableRepositoryR :: UUID -> Handler Html
getDisableRepositoryR uuid = notCurrentRepo uuid $ do getDisableRepositoryR uuid = notCurrentRepo uuid $ do
void $ liftAssistant $ disableRemote uuid void $ liftAssistant $ disableRemote uuid
redirect DashboardR redirect DashboardR
getDeleteRepositoryR :: UUID -> Handler RepHtml getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $ getDeleteRepositoryR uuid = notCurrentRepo uuid $
deletionPage $ do deletionPage $ do
reponame <- liftAnnex $ Remote.prettyUUID uuid reponame <- liftAnnex $ Remote.prettyUUID uuid
$(widgetFile "configurators/delete/start") $(widgetFile "configurators/delete/start")
getStartDeleteRepositoryR :: UUID -> Handler RepHtml getStartDeleteRepositoryR :: UUID -> Handler Html
getStartDeleteRepositoryR uuid = do getStartDeleteRepositoryR uuid = do
remote <- fromMaybe (error "unknown remote") remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid) <$> liftAnnex (Remote.remoteFromUUID uuid)
@ -55,7 +55,7 @@ getStartDeleteRepositoryR uuid = do
liftAssistant $ addScanRemotes True [remote] liftAssistant $ addScanRemotes True [remote]
redirect DashboardR redirect DashboardR
getFinishDeleteRepositoryR :: UUID -> Handler RepHtml getFinishDeleteRepositoryR :: UUID -> Handler Html
getFinishDeleteRepositoryR uuid = deletionPage $ do getFinishDeleteRepositoryR uuid = deletionPage $ do
void $ liftAssistant $ removeRemote uuid void $ liftAssistant $ removeRemote uuid
@ -64,13 +64,13 @@ getFinishDeleteRepositoryR uuid = deletionPage $ do
gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
$(widgetFile "configurators/delete/finished") $(widgetFile "configurators/delete/finished")
getDeleteCurrentRepositoryR :: Handler RepHtml getDeleteCurrentRepositoryR :: Handler Html
getDeleteCurrentRepositoryR = deleteCurrentRepository getDeleteCurrentRepositoryR = deleteCurrentRepository
postDeleteCurrentRepositoryR :: Handler RepHtml postDeleteCurrentRepositoryR :: Handler Html
postDeleteCurrentRepositoryR = deleteCurrentRepository postDeleteCurrentRepositoryR = deleteCurrentRepository
deleteCurrentRepository :: Handler RepHtml deleteCurrentRepository :: Handler Html
deleteCurrentRepository = dangerPage $ do deleteCurrentRepository = dangerPage $ do
reldir <- fromJust . relDir <$> liftH getYesod reldir <- fromJust . relDir <$> liftH getYesod
havegitremotes <- haveremotes syncGitRemotes havegitremotes <- haveremotes syncGitRemotes
@ -116,10 +116,10 @@ sanityVerifierAForm template = SanityVerifier
insane = "Maybe this is not a good idea..." :: Text insane = "Maybe this is not a good idea..." :: Text
deletionPage :: Widget -> Handler RepHtml deletionPage :: Widget -> Handler Html
deletionPage = page "Delete repository" (Just Configuration) deletionPage = page "Delete repository" (Just Configuration)
dangerPage :: Widget -> Handler RepHtml dangerPage :: Widget -> Handler Html
dangerPage = page "Danger danger danger" (Just Configuration) dangerPage = page "Danger danger danger" (Just Configuration)
magicphrase :: Text magicphrase :: Text

14
Assistant/WebApp/Configurators/Edit.hs
View file

@ -155,25 +155,25 @@ editRepositoryAForm ishere def = RepoConfig
Nothing -> aopt hiddenField "" Nothing Nothing -> aopt hiddenField "" Nothing
Just d -> aopt textField "Associated directory" (Just $ Just d) Just d -> aopt textField "Associated directory" (Just $ Just d)
getEditRepositoryR :: UUID -> Handler RepHtml getEditRepositoryR :: UUID -> Handler Html
getEditRepositoryR = postEditRepositoryR getEditRepositoryR = postEditRepositoryR
postEditRepositoryR :: UUID -> Handler RepHtml postEditRepositoryR :: UUID -> Handler Html
postEditRepositoryR = editForm False postEditRepositoryR = editForm False
getEditNewRepositoryR :: UUID -> Handler RepHtml getEditNewRepositoryR :: UUID -> Handler Html
getEditNewRepositoryR = postEditNewRepositoryR getEditNewRepositoryR = postEditNewRepositoryR
postEditNewRepositoryR :: UUID -> Handler RepHtml postEditNewRepositoryR :: UUID -> Handler Html
postEditNewRepositoryR = editForm True postEditNewRepositoryR = editForm True
getEditNewCloudRepositoryR :: UUID -> Handler RepHtml getEditNewCloudRepositoryR :: UUID -> Handler Html
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
postEditNewCloudRepositoryR :: UUID -> Handler RepHtml postEditNewCloudRepositoryR :: UUID -> Handler Html
postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
editForm :: Bool -> UUID -> Handler RepHtml editForm :: Bool -> UUID -> Handler Html
editForm new uuid = page "Edit repository" (Just Configuration) $ do editForm new uuid = page "Edit repository" (Just Configuration) $ do
mremote <- liftAnnex $ Remote.remoteFromUUID uuid mremote <- liftAnnex $ Remote.remoteFromUUID uuid
curr <- liftAnnex $ getRepoConfig uuid mremote curr <- liftAnnex $ getRepoConfig uuid mremote

10
Assistant/WebApp/Configurators/IA.hs
View file

@ -30,7 +30,7 @@ import qualified Data.Map as M
import Data.Char import Data.Char
import Network.URI import Network.URI
iaConfigurator :: Widget -> Handler RepHtml iaConfigurator :: Widget -> Handler Html
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration) iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
data IAInput = IAInput data IAInput = IAInput
@ -118,10 +118,10 @@ accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
Get Internet Archive access keys Get Internet Archive access keys
|] |]
getAddIAR :: Handler RepHtml getAddIAR :: Handler Html
getAddIAR = postAddIAR getAddIAR = postAddIAR
postAddIAR :: Handler RepHtml postAddIAR :: Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
postAddIAR = iaConfigurator $ do postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds defcreds <- liftAnnex previouslyUsedIACreds
@ -153,10 +153,10 @@ postAddIAR = iaConfigurator $ do
postAddIAR = error "S3 not supported by this build" postAddIAR = error "S3 not supported by this build"
#endif #endif
getEnableIAR :: UUID -> Handler RepHtml getEnableIAR :: UUID -> Handler Html
getEnableIAR = postEnableIAR getEnableIAR = postEnableIAR
postEnableIAR :: UUID -> Handler RepHtml postEnableIAR :: UUID -> Handler Html
#ifdef WITH_S3 #ifdef WITH_S3
postEnableIAR = iaConfigurator . enableIARemote postEnableIAR = iaConfigurator . enableIARemote
#else #else

25
Assistant/WebApp/Configurators/Local.hs
View file

@ -38,6 +38,7 @@ import Config
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
import qualified Text.Hamlet as Hamlet
data RepositoryPath = RepositoryPath Text data RepositoryPath = RepositoryPath Text
deriving Show deriving Show
@ -123,7 +124,7 @@ defaultRepositoryPath firstrun = do
) )
legit d = not <$> doesFileExist (d </> "git-annex") legit d = not <$> doesFileExist (d </> "git-annex")
newRepositoryForm :: FilePath -> Html -> MkMForm RepositoryPath newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
newRepositoryForm defpath msg = do newRepositoryForm defpath msg = do
(pathRes, pathView) <- mreq (repositoryPathField True) "" (pathRes, pathView) <- mreq (repositoryPathField True) ""
(Just $ T.pack $ addTrailingPathSeparator defpath) (Just $ T.pack $ addTrailingPathSeparator defpath)
@ -137,9 +138,9 @@ newRepositoryForm defpath msg = do
return (RepositoryPath <$> pathRes, form) return (RepositoryPath <$> pathRes, form)
{- Making the first repository, when starting the webapp for the first time. -} {- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler RepHtml getFirstRepositoryR :: Handler Html
getFirstRepositoryR = postFirstRepositoryR getFirstRepositoryR = postFirstRepositoryR
postFirstRepositoryR :: Handler RepHtml postFirstRepositoryR :: Handler Html
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
#ifdef __ANDROID__ #ifdef __ANDROID__
androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM" androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
@ -166,9 +167,9 @@ getAndroidCameraRepositoryR =
{- Adding a new local repository, which may be entirely separate, or may {- Adding a new local repository, which may be entirely separate, or may
- be connected to the current repository. -} - be connected to the current repository. -}
getNewRepositoryR :: Handler RepHtml getNewRepositoryR :: Handler Html
getNewRepositoryR = postNewRepositoryR getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler RepHtml postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir home <- liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home ((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home
@ -188,7 +189,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
mainrepo <- fromJust . relDir <$> liftH getYesod mainrepo <- fromJust . relDir <$> liftH getYesod
$(widgetFile "configurators/newrepository/combine") $(widgetFile "configurators/newrepository/combine")
getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml getCombineRepositoryR :: FilePathAndUUID -> Handler Html
getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
r <- combineRepos newrepopath remotename r <- combineRepos newrepopath remotename
liftAssistant $ syncRemote r liftAssistant $ syncRemote r
@ -196,7 +197,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
where where
remotename = takeFileName newrepopath remotename = takeFileName newrepopath
selectDriveForm :: [RemovableDrive] -> Html -> MkMForm RemovableDrive selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
selectDriveForm drives = renderBootstrap $ RemovableDrive selectDriveForm drives = renderBootstrap $ RemovableDrive
<$> pure Nothing <$> pure Nothing
<*> areq (selectFieldList pairs) "Select drive:" Nothing <*> areq (selectFieldList pairs) "Select drive:" Nothing
@ -219,9 +220,9 @@ removableDriveRepository drive =
T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive) T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
{- Adding a removable drive. -} {- Adding a removable drive. -}
getAddDriveR :: Handler RepHtml getAddDriveR :: Handler Html
getAddDriveR = postAddDriveR getAddDriveR = postAddDriveR
postAddDriveR :: Handler RepHtml postAddDriveR :: Handler Html
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO $ driveList removabledrives <- liftIO $ driveList
writabledrives <- liftIO $ writabledrives <- liftIO $
@ -236,7 +237,7 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
- that has already been used elsewhere. If so, check - that has already been used elsewhere. If so, check
- the UUID of the repo and see if it's one we know. If not, - the UUID of the repo and see if it's one we know. If not,
- the user must confirm the repository merge. -} - the user must confirm the repository merge. -}
getConfirmAddDriveR :: RemovableDrive -> Handler RepHtml getConfirmAddDriveR :: RemovableDrive -> Handler Html
getConfirmAddDriveR drive = do getConfirmAddDriveR drive = do
ifM (needconfirm) ifM (needconfirm)
( page "Combine repositories?" (Just Configuration) $ ( page "Combine repositories?" (Just Configuration) $
@ -260,7 +261,7 @@ getConfirmAddDriveR drive = do
cloneModal :: Widget cloneModal :: Widget
cloneModal = $(widgetFile "configurators/adddrive/clonemodal") cloneModal = $(widgetFile "configurators/adddrive/clonemodal")
getFinishAddDriveR :: RemovableDrive -> Handler RepHtml getFinishAddDriveR :: RemovableDrive -> Handler Html
getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR
where where
make = do make = do
@ -284,7 +285,7 @@ combineRepos dir name = liftAnnex $ do
liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
addRemote $ makeGitRemote name dir addRemote $ makeGitRemote name dir
getEnableDirectoryR :: UUID -> Handler RepHtml getEnableDirectoryR :: UUID -> Handler Html
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
description <- liftAnnex $ T.pack <$> prettyUUID uuid description <- liftAnnex $ T.pack <$> prettyUUID uuid
$(widgetFile "configurators/enabledirectory") $(widgetFile "configurators/enabledirectory")

36
Assistant/WebApp/Configurators/Pairing.hs
View file

@ -49,7 +49,7 @@ import Control.Concurrent
import qualified Data.Set as S import qualified Data.Set as S
#endif #endif
getStartXMPPPairFriendR :: Handler RepHtml getStartXMPPPairFriendR :: Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds) getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
( do ( do
@ -65,11 +65,11 @@ getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
#else #else
getStartXMPPPairFriendR = noXMPPPairing getStartXMPPPairFriendR = noXMPPPairing
noXMPPPairing :: Handler RepHtml noXMPPPairing :: Handler Html
noXMPPPairing = noPairing "XMPP" noXMPPPairing = noPairing "XMPP"
#endif #endif
getStartXMPPPairSelfR :: Handler RepHtml getStartXMPPPairSelfR :: Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
where where
@ -87,14 +87,14 @@ getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
getStartXMPPPairSelfR = noXMPPPairing getStartXMPPPairSelfR = noXMPPPairing
#endif #endif
getRunningXMPPPairFriendR :: BuddyKey -> Handler RepHtml getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
getRunningXMPPPairSelfR :: Handler RepHtml getRunningXMPPPairSelfR :: Handler Html
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
{- Sends a XMPP pair request, to a buddy or to self. -} {- Sends a XMPP pair request, to a buddy or to self. -}
sendXMPPPairRequest :: Maybe BuddyKey -> Handler RepHtml sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
sendXMPPPairRequest mbid = do sendXMPPPairRequest mbid = do
bid <- maybe getself return mbid bid <- maybe getself return mbid
@ -125,25 +125,25 @@ sendXMPPPairRequest _ = noXMPPPairing
#endif #endif
{- Starts local pairing. -} {- Starts local pairing. -}
getStartLocalPairR :: Handler RepHtml getStartLocalPairR :: Handler Html
getStartLocalPairR = postStartLocalPairR getStartLocalPairR = postStartLocalPairR
postStartLocalPairR :: Handler RepHtml postStartLocalPairR :: Handler Html
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
postStartLocalPairR = promptSecret Nothing $ postStartLocalPairR = promptSecret Nothing $
startLocalPairing PairReq noop pairingAlert Nothing startLocalPairing PairReq noop pairingAlert Nothing
#else #else
postStartLocalPairR = noLocalPairing postStartLocalPairR = noLocalPairing
noLocalPairing :: Handler RepHtml noLocalPairing :: Handler Html
noLocalPairing = noPairing "local" noLocalPairing = noPairing "local"
#endif #endif
{- Runs on the system that responds to a local pair request; sets up the ssh {- Runs on the system that responds to a local pair request; sets up the ssh
- authorized key first so that the originating host can immediately sync - authorized key first so that the originating host can immediately sync
- with us. -} - with us. -}
getFinishLocalPairR :: PairMsg -> Handler RepHtml getFinishLocalPairR :: PairMsg -> Handler Html
getFinishLocalPairR = postFinishLocalPairR getFinishLocalPairR = postFinishLocalPairR
postFinishLocalPairR :: PairMsg -> Handler RepHtml postFinishLocalPairR :: PairMsg -> Handler Html
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
repodir <- liftH $ repoPath <$> liftAnnex gitRepo repodir <- liftH $ repoPath <$> liftAnnex gitRepo
@ -159,7 +159,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
postFinishLocalPairR _ = noLocalPairing postFinishLocalPairR _ = noLocalPairing
#endif #endif
getConfirmXMPPPairFriendR :: PairKey -> Handler RepHtml getConfirmXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
Nothing -> error "bad JID" Nothing -> error "bad JID"
@ -170,7 +170,7 @@ getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
getConfirmXMPPPairFriendR _ = noXMPPPairing getConfirmXMPPPairFriendR _ = noXMPPPairing
#endif #endif
getFinishXMPPPairFriendR :: PairKey -> Handler RepHtml getFinishXMPPPairFriendR :: PairKey -> Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
Nothing -> error "bad JID" Nothing -> error "bad JID"
@ -188,13 +188,13 @@ getFinishXMPPPairFriendR _ = noXMPPPairing
{- Displays a page indicating pairing status and {- Displays a page indicating pairing status and
- prompting to set up cloud repositories. -} - prompting to set up cloud repositories. -}
#ifdef WITH_XMPP #ifdef WITH_XMPP
xmppPairStatus :: Bool -> Maybe JID -> Handler RepHtml xmppPairStatus :: Bool -> Maybe JID -> Handler Html
xmppPairStatus inprogress theirjid = pairPage $ do xmppPairStatus inprogress theirjid = pairPage $ do
let friend = buddyName <$> theirjid let friend = buddyName <$> theirjid
$(widgetFile "configurators/pairing/xmpp/end") $(widgetFile "configurators/pairing/xmpp/end")
#endif #endif
getRunningLocalPairR :: SecretReminder -> Handler RepHtml getRunningLocalPairR :: SecretReminder -> Handler Html
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
getRunningLocalPairR s = pairPage $ do getRunningLocalPairR s = pairPage $ do
let secret = fromSecretReminder s let secret = fromSecretReminder s
@ -262,7 +262,7 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
{- If a PairMsg is passed in, ensures that the user enters a secret {- If a PairMsg is passed in, ensures that the user enters a secret
- that can validate it. -} - that can validate it. -}
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
promptSecret msg cont = pairPage $ do promptSecret msg cont = pairPage $ do
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ runFormPost $ renderBootstrap $
@ -319,9 +319,9 @@ sampleQuote = T.unwords
#endif #endif
pairPage :: Widget -> Handler RepHtml pairPage :: Widget -> Handler Html
pairPage = page "Pairing" (Just Configuration) pairPage = page "Pairing" (Just Configuration)
noPairing :: Text -> Handler RepHtml noPairing :: Text -> Handler Html
noPairing pairingtype = pairPage $ noPairing pairingtype = pairPage $
$(widgetFile "configurators/pairing/disabled") $(widgetFile "configurators/pairing/disabled")

4
Assistant/WebApp/Configurators/Preferences.hs
View file

@ -84,9 +84,9 @@ storePrefs p = do
then enableDebugOutput then enableDebugOutput
else disableDebugOutput else disableDebugOutput
getPreferencesR :: Handler RepHtml getPreferencesR :: Handler Html
getPreferencesR = postPreferencesR getPreferencesR = postPreferencesR
postPreferencesR :: Handler RepHtml postPreferencesR :: Handler Html
postPreferencesR = page "Preferences" (Just Configuration) $ do postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- liftH $ do ((result, form), enctype) <- liftH $ do
current <- liftAnnex getPrefs current <- liftAnnex getPrefs

32
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -24,7 +24,7 @@ import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import Network.Socket import Network.Socket
sshConfigurator :: Widget -> Handler RepHtml sshConfigurator :: Widget -> Handler Html
sshConfigurator = page "Add a remote server" (Just Configuration) sshConfigurator = page "Add a remote server" (Just Configuration)
data SshInput = SshInput data SshInput = SshInput
@ -106,9 +106,9 @@ usable (UnusableServer _) = False
usable UsableRsyncServer = True usable UsableRsyncServer = True
usable UsableSshInput = True usable UsableSshInput = True
getAddSshR :: Handler RepHtml getAddSshR :: Handler Html
getAddSshR = postAddSshR getAddSshR = postAddSshR
postAddSshR :: Handler RepHtml postAddSshR :: Handler Html
postAddSshR = sshConfigurator $ do postAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName u <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
@ -135,9 +135,9 @@ sshTestModal = $(widgetFile "configurators/ssh/testmodal")
- Note that there's no EnableSshR because ssh remotes are not special - Note that there's no EnableSshR because ssh remotes are not special
- remotes, and so their configuration is not shared between repositories. - remotes, and so their configuration is not shared between repositories.
-} -}
getEnableRsyncR :: UUID -> Handler RepHtml getEnableRsyncR :: UUID -> Handler Html
getEnableRsyncR = postEnableRsyncR getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler RepHtml postEnableRsyncR :: UUID -> Handler Html
postEnableRsyncR u = do postEnableRsyncR u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
@ -253,18 +253,18 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
{- Runs a ssh command; if it fails shows the user the transcript, {- Runs a ssh command; if it fails shows the user the transcript,
- and if it succeeds, runs an action. -} - and if it succeeds, runs an action. -}
sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml sshSetup :: [String] -> String -> Handler Html -> Handler Html
sshSetup opts input a = do sshSetup opts input a = do
(transcript, ok) <- liftIO $ sshTranscript opts (Just input) (transcript, ok) <- liftIO $ sshTranscript opts (Just input)
if ok if ok
then a then a
else showSshErr transcript else showSshErr transcript
showSshErr :: String -> Handler RepHtml showSshErr :: String -> Handler Html
showSshErr msg = sshConfigurator $ showSshErr msg = sshConfigurator $
$(widgetFile "configurators/ssh/error") $(widgetFile "configurators/ssh/error")
getConfirmSshR :: SshData -> Handler RepHtml getConfirmSshR :: SshData -> Handler Html
getConfirmSshR sshdata = sshConfigurator $ getConfirmSshR sshdata = sshConfigurator $
$(widgetFile "configurators/ssh/confirm") $(widgetFile "configurators/ssh/confirm")
@ -273,13 +273,13 @@ getRetrySshR sshdata = do
s <- liftIO $ testServer $ mkSshInput sshdata s <- liftIO $ testServer $ mkSshInput sshdata
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
getMakeSshGitR :: SshData -> Handler RepHtml getMakeSshGitR :: SshData -> Handler Html
getMakeSshGitR = makeSsh False setupGroup getMakeSshGitR = makeSsh False setupGroup
getMakeSshRsyncR :: SshData -> Handler RepHtml getMakeSshRsyncR :: SshData -> Handler Html
getMakeSshRsyncR = makeSsh True setupGroup getMakeSshRsyncR = makeSsh True setupGroup
makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
makeSsh rsync setup sshdata makeSsh rsync setup sshdata
| needsPubKey sshdata = do | needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair keypair <- liftIO genSshKeyPair
@ -290,7 +290,7 @@ makeSsh rsync setup sshdata
makeSsh' rsync setup sshdata sshdata' Nothing makeSsh' rsync setup sshdata sshdata' Nothing
| otherwise = makeSsh' rsync setup sshdata sshdata Nothing | otherwise = makeSsh' rsync setup sshdata sshdata Nothing
makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> SshData -> Maybe SshKeyPair -> Handler RepHtml makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> SshData -> Maybe SshKeyPair -> Handler Html
makeSsh' rsync setup origsshdata sshdata keypair = do makeSsh' rsync setup origsshdata sshdata keypair = do
sshSetup [sshhost, remoteCommand] "" $ sshSetup [sshhost, remoteCommand] "" $
makeSshRepo rsync setup sshdata makeSshRepo rsync setup sshdata
@ -307,15 +307,15 @@ makeSsh' rsync setup origsshdata sshdata keypair = do
else Nothing else Nothing
] ]
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
makeSshRepo forcersync setup sshdata = do makeSshRepo forcersync setup sshdata = do
r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
setup r setup r
redirect $ EditNewCloudRepositoryR $ Remote.uuid r redirect $ EditNewCloudRepositoryR $ Remote.uuid r
getAddRsyncNetR :: Handler RepHtml getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler RepHtml postAddRsyncNetR :: Handler Html
postAddRsyncNetR = do postAddRsyncNetR = do
((result, form), enctype) <- runFormPost $ ((result, form), enctype) <- runFormPost $
renderBootstrap $ sshInputAForm hostnamefield $ renderBootstrap $ sshInputAForm hostnamefield $
@ -343,7 +343,7 @@ postAddRsyncNetR = do
user name something like "7491" user name something like "7491"
|] |]
makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
makeRsyncNet sshinput reponame setup = do makeRsyncNet sshinput reponame setup = do
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput) knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
keypair <- liftIO $ genSshKeyPair keypair <- liftIO $ genSshKeyPair

12
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -26,10 +26,10 @@ import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import Network.URI import Network.URI
webDAVConfigurator :: Widget -> Handler RepHtml webDAVConfigurator :: Widget -> Handler Html
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration) webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
boxConfigurator :: Widget -> Handler RepHtml boxConfigurator :: Widget -> Handler Html
boxConfigurator = page "Add a Box.com repository" (Just Configuration) boxConfigurator = page "Add a Box.com repository" (Just Configuration)
data WebDAVInput = WebDAVInput data WebDAVInput = WebDAVInput
@ -59,9 +59,9 @@ webDAVCredsAForm defcreds = WebDAVInput
<*> pure T.empty <*> pure T.empty
<*> pure NoEncryption -- not used! <*> pure NoEncryption -- not used!
getAddBoxComR :: Handler RepHtml getAddBoxComR :: Handler Html
getAddBoxComR = postAddBoxComR getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler RepHtml postAddBoxComR :: Handler Html
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
@ -87,9 +87,9 @@ postAddBoxComR = boxConfigurator $ do
postAddBoxComR = error "WebDAV not supported by this build" postAddBoxComR = error "WebDAV not supported by this build"
#endif #endif
getEnableWebDAVR :: UUID -> Handler RepHtml getEnableWebDAVR :: UUID -> Handler Html
getEnableWebDAVR = postEnableWebDAVR getEnableWebDAVR = postEnableWebDAVR
postEnableWebDAVR :: UUID -> Handler RepHtml postEnableWebDAVR :: UUID -> Handler Html
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
postEnableWebDAVR uuid = do postEnableWebDAVR uuid = do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog

22
Assistant/WebApp/Configurators/XMPP.hs
View file

@ -79,7 +79,7 @@ getBuddyName u = go =<< getclientjid
<$> getDaemonStatus <$> getDaemonStatus
#endif #endif
getNeedCloudRepoR :: UUID -> Handler RepHtml getNeedCloudRepoR :: UUID -> Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- liftAssistant $ getBuddyName for buddyname <- liftAssistant $ getBuddyName for
@ -89,25 +89,25 @@ getNeedCloudRepoR _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled") $(widgetFile "configurators/xmpp/disabled")
#endif #endif
getXMPPConfigR :: Handler RepHtml getXMPPConfigR :: Handler Html
getXMPPConfigR = postXMPPConfigR getXMPPConfigR = postXMPPConfigR
postXMPPConfigR :: Handler RepHtml postXMPPConfigR :: Handler Html
postXMPPConfigR = xmppform DashboardR postXMPPConfigR = xmppform DashboardR
getXMPPConfigForPairFriendR :: Handler RepHtml getXMPPConfigForPairFriendR :: Handler Html
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
postXMPPConfigForPairFriendR :: Handler RepHtml postXMPPConfigForPairFriendR :: Handler Html
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
getXMPPConfigForPairSelfR :: Handler RepHtml getXMPPConfigForPairSelfR :: Handler Html
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
postXMPPConfigForPairSelfR :: Handler RepHtml postXMPPConfigForPairSelfR :: Handler Html
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
xmppform :: Route WebApp -> Handler RepHtml xmppform :: Route WebApp -> Handler Html
#ifdef WITH_XMPP #ifdef WITH_XMPP
xmppform next = xmppPage $ do xmppform next = xmppPage $ do
((result, form), enctype) <- liftH $ do ((result, form), enctype) <- liftH $ do
@ -133,12 +133,12 @@ xmppform _ = xmppPage $
- -
- Returns a div, which will be inserted into the calling page. - Returns a div, which will be inserted into the calling page.
-} -}
getBuddyListR :: NotificationId -> Handler RepHtml getBuddyListR :: NotificationId -> Handler Html
getBuddyListR nid = do getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid waitNotifier getBuddyListBroadcaster nid
p <- widgetToPageContent buddyListDisplay p <- widgetToPageContent buddyListDisplay
hamletToRepHtml $ [hamlet|^{pageBody p}|] giveUrlRenderer $ [hamlet|^{pageBody p}|]
buddyListDisplay :: Widget buddyListDisplay :: Widget
buddyListDisplay = do buddyListDisplay = do
@ -216,5 +216,5 @@ testXMPP creds = do
showport (UnixSocket s) = s showport (UnixSocket s) = s
#endif #endif
xmppPage :: Widget -> Handler RepHtml xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration) xmppPage = page "Jabber" (Just Configuration)

8
Assistant/WebApp/Control.hs
View file

@ -20,11 +20,11 @@ import Control.Concurrent
import System.Posix (getProcessID, signalProcess, sigTERM) import System.Posix (getProcessID, signalProcess, sigTERM)
import qualified Data.Map as M import qualified Data.Map as M
getShutdownR :: Handler RepHtml getShutdownR :: Handler Html
getShutdownR = page "Shutdown" Nothing $ getShutdownR = page "Shutdown" Nothing $
$(widgetFile "control/shutdown") $(widgetFile "control/shutdown")
getShutdownConfirmedR :: Handler RepHtml getShutdownConfirmedR :: Handler Html
getShutdownConfirmedR = do getShutdownConfirmedR = do
{- Remove all alerts for currently running activities. -} {- Remove all alerts for currently running activities. -}
liftAssistant $ do liftAssistant $ do
@ -45,7 +45,7 @@ getShutdownConfirmedR = do
$(widgetFile "control/shutdownconfirmed") $(widgetFile "control/shutdownconfirmed")
{- Quite a hack, and doesn't redirect the browser window. -} {- Quite a hack, and doesn't redirect the browser window. -}
getRestartR :: Handler RepHtml getRestartR :: Handler Html
getRestartR = page "Restarting" Nothing $ do getRestartR = page "Restarting" Nothing $ do
void $ liftIO $ forkIO $ do void $ liftIO $ forkIO $ do
threadDelay 2000000 threadDelay 2000000
@ -63,7 +63,7 @@ getRestartThreadR name = do
liftIO $ maybe noop snd $ M.lookup name m liftIO $ maybe noop snd $ M.lookup name m
redirectBack redirectBack
getLogR :: Handler RepHtml getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexLogFile logfile <- liftAnnex $ fromRepo gitAnnexLogFile
logs <- liftIO $ listLogs logfile logs <- liftIO $ listLogs logfile

14
Assistant/WebApp/DashBoard.hs
View file

@ -23,7 +23,7 @@ import Types.Key
import qualified Remote import qualified Remote
import qualified Git import qualified Git
import Text.Hamlet import qualified Text.Hamlet as Hamlet
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent import Control.Concurrent
@ -62,12 +62,12 @@ simplifyTransfers (v@(t1, _):r@((t2, _):l))
- body is. To get the widget head content, the widget is also - body is. To get the widget head content, the widget is also
- inserted onto the getDashboardR page. - inserted onto the getDashboardR page.
-} -}
getTransfersR :: NotificationId -> Handler RepHtml getTransfersR :: NotificationId -> Handler Html
getTransfersR nid = do getTransfersR nid = do
waitNotifier getTransferBroadcaster nid waitNotifier getTransferBroadcaster nid
p <- widgetToPageContent $ transfersDisplay False p <- widgetToPageContent $ transfersDisplay False
hamletToRepHtml $ [hamlet|^{pageBody p}|] giveUrlRenderer $ [hamlet|^{pageBody p}|]
{- The main dashboard. -} {- The main dashboard. -}
dashboard :: Bool -> Widget dashboard :: Bool -> Widget
@ -77,7 +77,7 @@ dashboard warnNoScript = do
let transferlist = transfersDisplay warnNoScript let transferlist = transfersDisplay warnNoScript
$(widgetFile "dashboard/main") $(widgetFile "dashboard/main")
getDashboardR :: Handler RepHtml getDashboardR :: Handler Html
getDashboardR = ifM (inFirstRun) getDashboardR = ifM (inFirstRun)
( redirect ConfigurationR ( redirect ConfigurationR
, page "" (Just DashBoard) $ dashboard True , page "" (Just DashBoard) $ dashboard True
@ -88,16 +88,16 @@ headDashboardR :: Handler ()
headDashboardR = noop headDashboardR = noop
{- Same as DashboardR, except no autorefresh at all (and no noscript warning). -} {- Same as DashboardR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler RepHtml getNoScriptR :: Handler Html
getNoScriptR = page "" (Just DashBoard) $ dashboard False getNoScriptR = page "" (Just DashBoard) $ dashboard False
{- Same as DashboardR, except with autorefreshing via meta refresh. -} {- Same as DashboardR, except with autorefreshing via meta refresh. -}
getNoScriptAutoR :: Handler RepHtml getNoScriptAutoR :: Handler Html
getNoScriptAutoR = page "" (Just DashBoard) $ do getNoScriptAutoR = page "" (Just DashBoard) $ do
let ident = NoScriptR let ident = NoScriptR
let delayseconds = 3 :: Int let delayseconds = 3 :: Int
let this = NoScriptAutoR let this = NoScriptAutoR
toWidgetHead $(hamletFile $ hamletTemplate "dashboard/metarefresh") toWidgetHead $(Hamlet.hamletFile $ hamletTemplate "dashboard/metarefresh")
dashboard False dashboard False
{- The javascript code does a post. -} {- The javascript code does a post. -}

6
Assistant/WebApp/Documentation.hs
View file

@ -21,12 +21,12 @@ licenseFile = do
base <- standaloneAppBase base <- standaloneAppBase
return $ (</> "LICENSE") <$> base return $ (</> "LICENSE") <$> base
getAboutR :: Handler RepHtml getAboutR :: Handler Html
getAboutR = page "About git-annex" (Just About) $ do getAboutR = page "About git-annex" (Just About) $ do
builtinlicense <- isJust <$> liftIO licenseFile builtinlicense <- isJust <$> liftIO licenseFile
$(widgetFile "documentation/about") $(widgetFile "documentation/about")
getLicenseR :: Handler RepHtml getLicenseR :: Handler Html
getLicenseR = do getLicenseR = do
v <- liftIO licenseFile v <- liftIO licenseFile
case v of case v of
@ -37,6 +37,6 @@ getLicenseR = do
license <- liftIO $ readFile f license <- liftIO $ readFile f
$(widgetFile "documentation/license") $(widgetFile "documentation/license")
getRepoGroupR :: Handler RepHtml getRepoGroupR :: Handler Html
getRepoGroupR = page "About repository groups" (Just About) $ do getRepoGroupR = page "About repository groups" (Just About) $ do
$(widgetFile "documentation/repogroup") $(widgetFile "documentation/repogroup")

1
Assistant/WebApp/Notifications.hs
View file

@ -23,7 +23,6 @@ import Assistant.Types.Buddies
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Yesod import Utility.Yesod
import Yesod
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
#ifndef WITH_OLD_YESOD #ifndef WITH_OLD_YESOD

5
Assistant/WebApp/OtherRepos.hs
View file

@ -18,11 +18,10 @@ import Config.Files
import qualified Utility.Url as Url import qualified Utility.Url as Url
import Utility.Yesod import Utility.Yesod
import Yesod
import Control.Concurrent import Control.Concurrent
import System.Process (cwd) import System.Process (cwd)
getRepositorySwitcherR :: Handler RepHtml getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do getRepositorySwitcherR = page "Switch repository" Nothing $ do
repolist <- liftIO listOtherRepos repolist <- liftIO listOtherRepos
$(widgetFile "control/repositoryswitcher") $(widgetFile "control/repositoryswitcher")
@ -40,7 +39,7 @@ listOtherRepos = do
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for - a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. Once it's running, redirect to it. - connections by testing the url. Once it's running, redirect to it.
-} -}
getSwitchToRepositoryR :: FilePath -> Handler RepHtml getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do getSwitchToRepositoryR repo = do
liftIO $ startAssistant repo liftIO $ startAssistant repo
liftIO $ addAutoStartFile repo -- make this the new default repo liftIO $ addAutoStartFile repo -- make this the new default repo

9
Assistant/WebApp/Page.hs
View file

@ -15,8 +15,7 @@ import Assistant.WebApp.Types
import Assistant.WebApp.SideBar import Assistant.WebApp.SideBar
import Utility.Yesod import Utility.Yesod
import Yesod import qualified Text.Hamlet as Hamlet
import Text.Hamlet
import Data.Text (Text) import Data.Text (Text)
data NavBarItem = DashBoard | Configuration | About data NavBarItem = DashBoard | Configuration | About
@ -43,14 +42,14 @@ selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
{- A standard page of the webapp, with a title, a sidebar, and that may {- A standard page of the webapp, with a title, a sidebar, and that may
- be highlighted on the navbar. -} - be highlighted on the navbar. -}
page :: Html -> Maybe NavBarItem -> Widget -> Handler RepHtml page :: Hamlet.Html -> Maybe NavBarItem -> Widget -> Handler Html
page title navbaritem content = customPage navbaritem $ do page title navbaritem content = customPage navbaritem $ do
setTitle title setTitle title
sideBarDisplay sideBarDisplay
content content
{- A custom page, with no title or sidebar set. -} {- A custom page, with no title or sidebar set. -}
customPage :: Maybe NavBarItem -> Widget -> Handler RepHtml customPage :: Maybe NavBarItem -> Widget -> Handler Html
customPage navbaritem content = do customPage navbaritem content = do
webapp <- getYesod webapp <- getYesod
navbar <- map navdetails <$> selectNavBar navbar <- map navdetails <$> selectNavBar
@ -62,7 +61,7 @@ customPage navbaritem content = do
addScript $ StaticR js_bootstrap_modal_js addScript $ StaticR js_bootstrap_modal_js
addScript $ StaticR js_bootstrap_collapse_js addScript $ StaticR js_bootstrap_collapse_js
$(widgetFile "page") $(widgetFile "page")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap") giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
where where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem) navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)

4
Assistant/WebApp/RepoList.hs
View file

@ -79,11 +79,11 @@ notWanted _ = False
- -
- Returns a div, which will be inserted into the calling page. - Returns a div, which will be inserted into the calling page.
-} -}
getRepoListR :: RepoListNotificationId -> Handler RepHtml getRepoListR :: RepoListNotificationId -> Handler Html
getRepoListR (RepoListNotificationId nid reposelector) = do getRepoListR (RepoListNotificationId nid reposelector) = do
waitNotifier getRepoListBroadcaster nid waitNotifier getRepoListBroadcaster nid
p <- widgetToPageContent $ repoListDisplay reposelector p <- widgetToPageContent $ repoListDisplay reposelector
hamletToRepHtml $ [hamlet|^{pageBody p}|] giveUrlRenderer $ [hamlet|^{pageBody p}|]
mainRepoSelector :: RepoSelector mainRepoSelector :: RepoSelector
mainRepoSelector = RepoSelector mainRepoSelector = RepoSelector

5
Assistant/WebApp/SideBar.hs
View file

@ -18,7 +18,6 @@ import Assistant.DaemonStatus
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Yesod import Utility.Yesod
import Yesod
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
@ -61,7 +60,7 @@ sideBarDisplay = do
- body is. To get the widget head content, the widget is also - body is. To get the widget head content, the widget is also
- inserted onto all pages. - inserted onto all pages.
-} -}
getSideBarR :: NotificationId -> Handler RepHtml getSideBarR :: NotificationId -> Handler Html
getSideBarR nid = do getSideBarR nid = do
waitNotifier getAlertBroadcaster nid waitNotifier getAlertBroadcaster nid
@ -73,7 +72,7 @@ getSideBarR nid = do
liftIO $ threadDelay 100000 liftIO $ threadDelay 100000
page <- widgetToPageContent sideBarDisplay page <- widgetToPageContent sideBarDisplay
hamletToRepHtml $ [hamlet|^{pageBody page}|] giveUrlRenderer $ [hamlet|^{pageBody page}|]
{- Called by the client to close an alert. -} {- Called by the client to close an alert. -}
getCloseAlert :: AlertId -> Handler () getCloseAlert :: AlertId -> Handler ()

3
Assistant/WebApp/Types.hs
View file

@ -23,7 +23,6 @@ import Utility.Yesod
import Logs.Transfer import Logs.Transfer
import Build.SysConfig (packageversion) import Build.SysConfig (packageversion)
import Yesod
import Yesod.Static import Yesod.Static
import Text.Hamlet import Text.Hamlet
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
@ -72,7 +71,7 @@ instance Yesod WebApp where
addStylesheet $ StaticR css_bootstrap_css addStylesheet $ StaticR css_bootstrap_css
addStylesheet $ StaticR css_bootstrap_responsive_css addStylesheet $ StaticR css_bootstrap_responsive_css
$(widgetFile "error") $(widgetFile "error")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap") giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")
instance RenderMessage WebApp FormMessage where instance RenderMessage WebApp FormMessage where
renderMessage _ _ = defaultFormMessage renderMessage _ _ = defaultFormMessage

28
Utility/Yesod.hs
View file

@ -10,18 +10,28 @@
{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} {-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}
module Utility.Yesod where module Utility.Yesod
( module Y
, widgetFile
, hamletTemplate
, liftH
#if ! MIN_VERSION_yesod(1,2,0)
, giveUrlRenderer
, Html
#endif
) where
import Yesod #if MIN_VERSION_yesod(1,2,0)
#if MIN_VERSION_yesod_default(1,2,0) import Yesod as Y
import Yesod.Core #else
import Yesod as Y hiding (Html)
#endif #endif
#ifndef __ANDROID__ #ifndef __ANDROID__
import Yesod.Default.Util import Yesod.Default.Util
import Language.Haskell.TH.Syntax (Q, Exp) import Language.Haskell.TH.Syntax (Q, Exp)
#if MIN_VERSION_yesod_default(1,1,0) #if MIN_VERSION_yesod_default(1,1,0)
import Data.Default (def) import Data.Default (def)
import Text.Hamlet import Text.Hamlet hiding (Html)
#endif #endif
widgetFile :: String -> Q Exp widgetFile :: String -> Q Exp
@ -47,3 +57,11 @@ liftH = handlerToWidget
liftH :: MonadLift base m => base a -> m a liftH :: MonadLift base m => base a -> m a
liftH = lift liftH = lift
#endif #endif
{- Misc new names for stuff. -}
#if ! MIN_VERSION_yesod(1,2,0)
giveUrlRenderer :: forall master sub. HtmlUrl (Route master) -> GHandler sub master RepHtml
giveUrlRenderer = hamletToRepHtml
type Html = RepHtml
#endif