clean up build warnings with yesod 1.2, while still building with 1.1
This commit is contained in:
Joey Hess
parent
b44c978e2c
commit
ff4f008591
23 changed files with 149 additions and 137 deletions
|
|
@ -15,7 +15,6 @@ import Assistant.Common
|
|||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import Control.Concurrent
|
||||
import qualified Network.Wai as W
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ import Assistant.WebApp as X
|
|||
import Assistant.WebApp.Page as X
|
||||
import Assistant.WebApp.Form 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 Yesod as X hiding (textField, passwordField, insertBy, replace, joinPath, deleteBy, delete, insert, Key, Option)
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ import Assistant.XMPP.Client
|
|||
#endif
|
||||
|
||||
{- The main configuration screen. -}
|
||||
getConfigurationR :: Handler RepHtml
|
||||
getConfigurationR :: Handler Html
|
||||
getConfigurationR = ifM (inFirstRun)
|
||||
( redirect FirstRepositoryR
|
||||
, page "Configuration" (Just Configuration) $ do
|
||||
|
|
@ -28,7 +28,7 @@ getConfigurationR = ifM (inFirstRun)
|
|||
$(widgetFile "configurators/main")
|
||||
)
|
||||
|
||||
getAddRepositoryR :: Handler RepHtml
|
||||
getAddRepositoryR :: Handler Html
|
||||
getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
|
||||
let repolist = repoListDisplay mainRepoSelector
|
||||
$(widgetFile "configurators/addrepository")
|
||||
|
|
|
|||
|
|
@ -29,10 +29,10 @@ import qualified Data.Text as T
|
|||
import qualified Data.Map as M
|
||||
import Data.Char
|
||||
|
||||
awsConfigurator :: Widget -> Handler RepHtml
|
||||
awsConfigurator :: Widget -> Handler Html
|
||||
awsConfigurator = page "Add an Amazon repository" (Just Configuration)
|
||||
|
||||
glacierConfigurator :: Widget -> Handler RepHtml
|
||||
glacierConfigurator :: Widget -> Handler Html
|
||||
glacierConfigurator a = do
|
||||
ifM (liftIO $ inPath "glacier")
|
||||
( awsConfigurator a
|
||||
|
|
@ -112,10 +112,10 @@ datacenterField service = areq (selectFieldList list) "Datacenter" defregion
|
|||
list = M.toList $ AWS.regionMap service
|
||||
defregion = Just $ AWS.defaultRegion service
|
||||
|
||||
getAddS3R :: Handler RepHtml
|
||||
getAddS3R :: Handler Html
|
||||
getAddS3R = postAddS3R
|
||||
|
||||
postAddS3R :: Handler RepHtml
|
||||
postAddS3R :: Handler Html
|
||||
#ifdef WITH_S3
|
||||
postAddS3R = awsConfigurator $ do
|
||||
defcreds <- liftAnnex previouslyUsedAWSCreds
|
||||
|
|
@ -138,10 +138,10 @@ postAddS3R = awsConfigurator $ do
|
|||
postAddS3R = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getAddGlacierR :: Handler RepHtml
|
||||
getAddGlacierR :: Handler Html
|
||||
getAddGlacierR = postAddGlacierR
|
||||
|
||||
postAddGlacierR :: Handler RepHtml
|
||||
postAddGlacierR :: Handler Html
|
||||
#ifdef WITH_S3
|
||||
postAddGlacierR = glacierConfigurator $ do
|
||||
defcreds <- liftAnnex previouslyUsedAWSCreds
|
||||
|
|
@ -163,7 +163,7 @@ postAddGlacierR = glacierConfigurator $ do
|
|||
postAddGlacierR = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableS3R :: UUID -> Handler RepHtml
|
||||
getEnableS3R :: UUID -> Handler Html
|
||||
#ifdef WITH_S3
|
||||
getEnableS3R uuid = do
|
||||
m <- liftAnnex readRemoteLog
|
||||
|
|
@ -174,17 +174,17 @@ getEnableS3R uuid = do
|
|||
getEnableS3R = postEnableS3R
|
||||
#endif
|
||||
|
||||
postEnableS3R :: UUID -> Handler RepHtml
|
||||
postEnableS3R :: UUID -> Handler Html
|
||||
#ifdef WITH_S3
|
||||
postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
|
||||
#else
|
||||
postEnableS3R _ = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableGlacierR :: UUID -> Handler RepHtml
|
||||
getEnableGlacierR :: UUID -> Handler Html
|
||||
getEnableGlacierR = postEnableGlacierR
|
||||
|
||||
postEnableGlacierR :: UUID -> Handler RepHtml
|
||||
postEnableGlacierR :: UUID -> Handler Html
|
||||
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
|
||||
|
||||
enableAWSRemote :: RemoteType -> UUID -> Widget
|
||||
|
|
|
|||
|
|
@ -28,24 +28,24 @@ import qualified Data.Text as T
|
|||
import qualified Data.Map as M
|
||||
import System.Path
|
||||
|
||||
notCurrentRepo :: UUID -> Handler RepHtml -> Handler RepHtml
|
||||
notCurrentRepo :: UUID -> Handler Html -> Handler Html
|
||||
notCurrentRepo uuid a = go =<< liftAnnex (Remote.remoteFromUUID uuid)
|
||||
where
|
||||
go Nothing = redirect DeleteCurrentRepositoryR
|
||||
go (Just _) = a
|
||||
|
||||
getDisableRepositoryR :: UUID -> Handler RepHtml
|
||||
getDisableRepositoryR :: UUID -> Handler Html
|
||||
getDisableRepositoryR uuid = notCurrentRepo uuid $ do
|
||||
void $ liftAssistant $ disableRemote uuid
|
||||
redirect DashboardR
|
||||
|
||||
getDeleteRepositoryR :: UUID -> Handler RepHtml
|
||||
getDeleteRepositoryR :: UUID -> Handler Html
|
||||
getDeleteRepositoryR uuid = notCurrentRepo uuid $
|
||||
deletionPage $ do
|
||||
reponame <- liftAnnex $ Remote.prettyUUID uuid
|
||||
$(widgetFile "configurators/delete/start")
|
||||
|
||||
getStartDeleteRepositoryR :: UUID -> Handler RepHtml
|
||||
getStartDeleteRepositoryR :: UUID -> Handler Html
|
||||
getStartDeleteRepositoryR uuid = do
|
||||
remote <- fromMaybe (error "unknown remote")
|
||||
<$> liftAnnex (Remote.remoteFromUUID uuid)
|
||||
|
|
@ -55,7 +55,7 @@ getStartDeleteRepositoryR uuid = do
|
|||
liftAssistant $ addScanRemotes True [remote]
|
||||
redirect DashboardR
|
||||
|
||||
getFinishDeleteRepositoryR :: UUID -> Handler RepHtml
|
||||
getFinishDeleteRepositoryR :: UUID -> Handler Html
|
||||
getFinishDeleteRepositoryR uuid = deletionPage $ do
|
||||
void $ liftAssistant $ removeRemote uuid
|
||||
|
||||
|
|
@ -64,13 +64,13 @@ getFinishDeleteRepositoryR uuid = deletionPage $ do
|
|||
gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
|
||||
$(widgetFile "configurators/delete/finished")
|
||||
|
||||
getDeleteCurrentRepositoryR :: Handler RepHtml
|
||||
getDeleteCurrentRepositoryR :: Handler Html
|
||||
getDeleteCurrentRepositoryR = deleteCurrentRepository
|
||||
|
||||
postDeleteCurrentRepositoryR :: Handler RepHtml
|
||||
postDeleteCurrentRepositoryR :: Handler Html
|
||||
postDeleteCurrentRepositoryR = deleteCurrentRepository
|
||||
|
||||
deleteCurrentRepository :: Handler RepHtml
|
||||
deleteCurrentRepository :: Handler Html
|
||||
deleteCurrentRepository = dangerPage $ do
|
||||
reldir <- fromJust . relDir <$> liftH getYesod
|
||||
havegitremotes <- haveremotes syncGitRemotes
|
||||
|
|
@ -116,10 +116,10 @@ sanityVerifierAForm template = SanityVerifier
|
|||
|
||||
insane = "Maybe this is not a good idea..." :: Text
|
||||
|
||||
deletionPage :: Widget -> Handler RepHtml
|
||||
deletionPage :: Widget -> Handler Html
|
||||
deletionPage = page "Delete repository" (Just Configuration)
|
||||
|
||||
dangerPage :: Widget -> Handler RepHtml
|
||||
dangerPage :: Widget -> Handler Html
|
||||
dangerPage = page "Danger danger danger" (Just Configuration)
|
||||
|
||||
magicphrase :: Text
|
||||
|
|
|
|||
|
|
@ -155,25 +155,25 @@ editRepositoryAForm ishere def = RepoConfig
|
|||
Nothing -> aopt hiddenField "" Nothing
|
||||
Just d -> aopt textField "Associated directory" (Just $ Just d)
|
||||
|
||||
getEditRepositoryR :: UUID -> Handler RepHtml
|
||||
getEditRepositoryR :: UUID -> Handler Html
|
||||
getEditRepositoryR = postEditRepositoryR
|
||||
|
||||
postEditRepositoryR :: UUID -> Handler RepHtml
|
||||
postEditRepositoryR :: UUID -> Handler Html
|
||||
postEditRepositoryR = editForm False
|
||||
|
||||
getEditNewRepositoryR :: UUID -> Handler RepHtml
|
||||
getEditNewRepositoryR :: UUID -> Handler Html
|
||||
getEditNewRepositoryR = postEditNewRepositoryR
|
||||
|
||||
postEditNewRepositoryR :: UUID -> Handler RepHtml
|
||||
postEditNewRepositoryR :: UUID -> Handler Html
|
||||
postEditNewRepositoryR = editForm True
|
||||
|
||||
getEditNewCloudRepositoryR :: UUID -> Handler RepHtml
|
||||
getEditNewCloudRepositoryR :: UUID -> Handler Html
|
||||
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
|
||||
|
||||
postEditNewCloudRepositoryR :: UUID -> Handler RepHtml
|
||||
postEditNewCloudRepositoryR :: UUID -> Handler Html
|
||||
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
|
||||
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
|
||||
curr <- liftAnnex $ getRepoConfig uuid mremote
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ import qualified Data.Map as M
|
|||
import Data.Char
|
||||
import Network.URI
|
||||
|
||||
iaConfigurator :: Widget -> Handler RepHtml
|
||||
iaConfigurator :: Widget -> Handler Html
|
||||
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
|
||||
|
||||
data IAInput = IAInput
|
||||
|
|
@ -118,10 +118,10 @@ accessKeyIDFieldWithHelp def = AWS.accessKeyIDField help def
|
|||
Get Internet Archive access keys
|
||||
|]
|
||||
|
||||
getAddIAR :: Handler RepHtml
|
||||
getAddIAR :: Handler Html
|
||||
getAddIAR = postAddIAR
|
||||
|
||||
postAddIAR :: Handler RepHtml
|
||||
postAddIAR :: Handler Html
|
||||
#ifdef WITH_S3
|
||||
postAddIAR = iaConfigurator $ do
|
||||
defcreds <- liftAnnex previouslyUsedIACreds
|
||||
|
|
@ -153,10 +153,10 @@ postAddIAR = iaConfigurator $ do
|
|||
postAddIAR = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableIAR :: UUID -> Handler RepHtml
|
||||
getEnableIAR :: UUID -> Handler Html
|
||||
getEnableIAR = postEnableIAR
|
||||
|
||||
postEnableIAR :: UUID -> Handler RepHtml
|
||||
postEnableIAR :: UUID -> Handler Html
|
||||
#ifdef WITH_S3
|
||||
postEnableIAR = iaConfigurator . enableIARemote
|
||||
#else
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ import Config
|
|||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import Data.Char
|
||||
import qualified Text.Hamlet as Hamlet
|
||||
|
||||
data RepositoryPath = RepositoryPath Text
|
||||
deriving Show
|
||||
|
|
@ -123,7 +124,7 @@ defaultRepositoryPath firstrun = do
|
|||
)
|
||||
legit d = not <$> doesFileExist (d </> "git-annex")
|
||||
|
||||
newRepositoryForm :: FilePath -> Html -> MkMForm RepositoryPath
|
||||
newRepositoryForm :: FilePath -> Hamlet.Html -> MkMForm RepositoryPath
|
||||
newRepositoryForm defpath msg = do
|
||||
(pathRes, pathView) <- mreq (repositoryPathField True) ""
|
||||
(Just $ T.pack $ addTrailingPathSeparator defpath)
|
||||
|
|
@ -137,9 +138,9 @@ newRepositoryForm defpath msg = do
|
|||
return (RepositoryPath <$> pathRes, form)
|
||||
|
||||
{- Making the first repository, when starting the webapp for the first time. -}
|
||||
getFirstRepositoryR :: Handler RepHtml
|
||||
getFirstRepositoryR :: Handler Html
|
||||
getFirstRepositoryR = postFirstRepositoryR
|
||||
postFirstRepositoryR :: Handler RepHtml
|
||||
postFirstRepositoryR :: Handler Html
|
||||
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
|
||||
#ifdef __ANDROID__
|
||||
androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"
|
||||
|
|
@ -166,9 +167,9 @@ getAndroidCameraRepositoryR =
|
|||
|
||||
{- Adding a new local repository, which may be entirely separate, or may
|
||||
- be connected to the current repository. -}
|
||||
getNewRepositoryR :: Handler RepHtml
|
||||
getNewRepositoryR :: Handler Html
|
||||
getNewRepositoryR = postNewRepositoryR
|
||||
postNewRepositoryR :: Handler RepHtml
|
||||
postNewRepositoryR :: Handler Html
|
||||
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
||||
home <- liftIO myHomeDir
|
||||
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home
|
||||
|
|
@ -188,7 +189,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
|||
mainrepo <- fromJust . relDir <$> liftH getYesod
|
||||
$(widgetFile "configurators/newrepository/combine")
|
||||
|
||||
getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml
|
||||
getCombineRepositoryR :: FilePathAndUUID -> Handler Html
|
||||
getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
|
||||
r <- combineRepos newrepopath remotename
|
||||
liftAssistant $ syncRemote r
|
||||
|
|
@ -196,7 +197,7 @@ getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do
|
|||
where
|
||||
remotename = takeFileName newrepopath
|
||||
|
||||
selectDriveForm :: [RemovableDrive] -> Html -> MkMForm RemovableDrive
|
||||
selectDriveForm :: [RemovableDrive] -> Hamlet.Html -> MkMForm RemovableDrive
|
||||
selectDriveForm drives = renderBootstrap $ RemovableDrive
|
||||
<$> pure Nothing
|
||||
<*> areq (selectFieldList pairs) "Select drive:" Nothing
|
||||
|
|
@ -219,9 +220,9 @@ removableDriveRepository drive =
|
|||
T.unpack (mountPoint drive) </> T.unpack (driveRepoPath drive)
|
||||
|
||||
{- Adding a removable drive. -}
|
||||
getAddDriveR :: Handler RepHtml
|
||||
getAddDriveR :: Handler Html
|
||||
getAddDriveR = postAddDriveR
|
||||
postAddDriveR :: Handler RepHtml
|
||||
postAddDriveR :: Handler Html
|
||||
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
|
||||
removabledrives <- liftIO $ driveList
|
||||
writabledrives <- liftIO $
|
||||
|
|
@ -236,7 +237,7 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
|
|||
- 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 user must confirm the repository merge. -}
|
||||
getConfirmAddDriveR :: RemovableDrive -> Handler RepHtml
|
||||
getConfirmAddDriveR :: RemovableDrive -> Handler Html
|
||||
getConfirmAddDriveR drive = do
|
||||
ifM (needconfirm)
|
||||
( page "Combine repositories?" (Just Configuration) $
|
||||
|
|
@ -260,7 +261,7 @@ getConfirmAddDriveR drive = do
|
|||
cloneModal :: Widget
|
||||
cloneModal = $(widgetFile "configurators/adddrive/clonemodal")
|
||||
|
||||
getFinishAddDriveR :: RemovableDrive -> Handler RepHtml
|
||||
getFinishAddDriveR :: RemovableDrive -> Handler Html
|
||||
getFinishAddDriveR drive = make >>= redirect . EditNewRepositoryR
|
||||
where
|
||||
make = do
|
||||
|
|
@ -284,7 +285,7 @@ combineRepos dir name = liftAnnex $ do
|
|||
liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
|
||||
addRemote $ makeGitRemote name dir
|
||||
|
||||
getEnableDirectoryR :: UUID -> Handler RepHtml
|
||||
getEnableDirectoryR :: UUID -> Handler Html
|
||||
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
|
||||
description <- liftAnnex $ T.pack <$> prettyUUID uuid
|
||||
$(widgetFile "configurators/enabledirectory")
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ import Control.Concurrent
|
|||
import qualified Data.Set as S
|
||||
#endif
|
||||
|
||||
getStartXMPPPairFriendR :: Handler RepHtml
|
||||
getStartXMPPPairFriendR :: Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
|
||||
( do
|
||||
|
|
@ -65,11 +65,11 @@ getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
|
|||
#else
|
||||
getStartXMPPPairFriendR = noXMPPPairing
|
||||
|
||||
noXMPPPairing :: Handler RepHtml
|
||||
noXMPPPairing :: Handler Html
|
||||
noXMPPPairing = noPairing "XMPP"
|
||||
#endif
|
||||
|
||||
getStartXMPPPairSelfR :: Handler RepHtml
|
||||
getStartXMPPPairSelfR :: Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
|
||||
where
|
||||
|
|
@ -87,14 +87,14 @@ getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
|
|||
getStartXMPPPairSelfR = noXMPPPairing
|
||||
#endif
|
||||
|
||||
getRunningXMPPPairFriendR :: BuddyKey -> Handler RepHtml
|
||||
getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
|
||||
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
|
||||
|
||||
getRunningXMPPPairSelfR :: Handler RepHtml
|
||||
getRunningXMPPPairSelfR :: Handler Html
|
||||
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
|
||||
|
||||
{- Sends a XMPP pair request, to a buddy or to self. -}
|
||||
sendXMPPPairRequest :: Maybe BuddyKey -> Handler RepHtml
|
||||
sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
sendXMPPPairRequest mbid = do
|
||||
bid <- maybe getself return mbid
|
||||
|
|
@ -125,25 +125,25 @@ sendXMPPPairRequest _ = noXMPPPairing
|
|||
#endif
|
||||
|
||||
{- Starts local pairing. -}
|
||||
getStartLocalPairR :: Handler RepHtml
|
||||
getStartLocalPairR :: Handler Html
|
||||
getStartLocalPairR = postStartLocalPairR
|
||||
postStartLocalPairR :: Handler RepHtml
|
||||
postStartLocalPairR :: Handler Html
|
||||
#ifdef WITH_PAIRING
|
||||
postStartLocalPairR = promptSecret Nothing $
|
||||
startLocalPairing PairReq noop pairingAlert Nothing
|
||||
#else
|
||||
postStartLocalPairR = noLocalPairing
|
||||
|
||||
noLocalPairing :: Handler RepHtml
|
||||
noLocalPairing :: Handler Html
|
||||
noLocalPairing = noPairing "local"
|
||||
#endif
|
||||
|
||||
{- 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
|
||||
- with us. -}
|
||||
getFinishLocalPairR :: PairMsg -> Handler RepHtml
|
||||
getFinishLocalPairR :: PairMsg -> Handler Html
|
||||
getFinishLocalPairR = postFinishLocalPairR
|
||||
postFinishLocalPairR :: PairMsg -> Handler RepHtml
|
||||
postFinishLocalPairR :: PairMsg -> Handler Html
|
||||
#ifdef WITH_PAIRING
|
||||
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
||||
repodir <- liftH $ repoPath <$> liftAnnex gitRepo
|
||||
|
|
@ -159,7 +159,7 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
|||
postFinishLocalPairR _ = noLocalPairing
|
||||
#endif
|
||||
|
||||
getConfirmXMPPPairFriendR :: PairKey -> Handler RepHtml
|
||||
getConfirmXMPPPairFriendR :: PairKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
|
||||
Nothing -> error "bad JID"
|
||||
|
|
@ -170,7 +170,7 @@ getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
|
|||
getConfirmXMPPPairFriendR _ = noXMPPPairing
|
||||
#endif
|
||||
|
||||
getFinishXMPPPairFriendR :: PairKey -> Handler RepHtml
|
||||
getFinishXMPPPairFriendR :: PairKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
|
||||
Nothing -> error "bad JID"
|
||||
|
|
@ -188,13 +188,13 @@ getFinishXMPPPairFriendR _ = noXMPPPairing
|
|||
{- Displays a page indicating pairing status and
|
||||
- prompting to set up cloud repositories. -}
|
||||
#ifdef WITH_XMPP
|
||||
xmppPairStatus :: Bool -> Maybe JID -> Handler RepHtml
|
||||
xmppPairStatus :: Bool -> Maybe JID -> Handler Html
|
||||
xmppPairStatus inprogress theirjid = pairPage $ do
|
||||
let friend = buddyName <$> theirjid
|
||||
$(widgetFile "configurators/pairing/xmpp/end")
|
||||
#endif
|
||||
|
||||
getRunningLocalPairR :: SecretReminder -> Handler RepHtml
|
||||
getRunningLocalPairR :: SecretReminder -> Handler Html
|
||||
#ifdef WITH_PAIRING
|
||||
getRunningLocalPairR s = pairPage $ do
|
||||
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
|
||||
- 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
|
||||
((result, form), enctype) <- liftH $
|
||||
runFormPost $ renderBootstrap $
|
||||
|
|
@ -319,9 +319,9 @@ sampleQuote = T.unwords
|
|||
|
||||
#endif
|
||||
|
||||
pairPage :: Widget -> Handler RepHtml
|
||||
pairPage :: Widget -> Handler Html
|
||||
pairPage = page "Pairing" (Just Configuration)
|
||||
|
||||
noPairing :: Text -> Handler RepHtml
|
||||
noPairing :: Text -> Handler Html
|
||||
noPairing pairingtype = pairPage $
|
||||
$(widgetFile "configurators/pairing/disabled")
|
||||
|
|
|
|||
|
|
@ -84,9 +84,9 @@ storePrefs p = do
|
|||
then enableDebugOutput
|
||||
else disableDebugOutput
|
||||
|
||||
getPreferencesR :: Handler RepHtml
|
||||
getPreferencesR :: Handler Html
|
||||
getPreferencesR = postPreferencesR
|
||||
postPreferencesR :: Handler RepHtml
|
||||
postPreferencesR :: Handler Html
|
||||
postPreferencesR = page "Preferences" (Just Configuration) $ do
|
||||
((result, form), enctype) <- liftH $ do
|
||||
current <- liftAnnex getPrefs
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Map as M
|
||||
import Network.Socket
|
||||
|
||||
sshConfigurator :: Widget -> Handler RepHtml
|
||||
sshConfigurator :: Widget -> Handler Html
|
||||
sshConfigurator = page "Add a remote server" (Just Configuration)
|
||||
|
||||
data SshInput = SshInput
|
||||
|
|
@ -106,9 +106,9 @@ usable (UnusableServer _) = False
|
|||
usable UsableRsyncServer = True
|
||||
usable UsableSshInput = True
|
||||
|
||||
getAddSshR :: Handler RepHtml
|
||||
getAddSshR :: Handler Html
|
||||
getAddSshR = postAddSshR
|
||||
postAddSshR :: Handler RepHtml
|
||||
postAddSshR :: Handler Html
|
||||
postAddSshR = sshConfigurator $ do
|
||||
u <- liftIO $ T.pack <$> myUserName
|
||||
((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
|
||||
- remotes, and so their configuration is not shared between repositories.
|
||||
-}
|
||||
getEnableRsyncR :: UUID -> Handler RepHtml
|
||||
getEnableRsyncR :: UUID -> Handler Html
|
||||
getEnableRsyncR = postEnableRsyncR
|
||||
postEnableRsyncR :: UUID -> Handler RepHtml
|
||||
postEnableRsyncR :: UUID -> Handler Html
|
||||
postEnableRsyncR u = do
|
||||
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
|
||||
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,
|
||||
- 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
|
||||
(transcript, ok) <- liftIO $ sshTranscript opts (Just input)
|
||||
if ok
|
||||
then a
|
||||
else showSshErr transcript
|
||||
|
||||
showSshErr :: String -> Handler RepHtml
|
||||
showSshErr :: String -> Handler Html
|
||||
showSshErr msg = sshConfigurator $
|
||||
$(widgetFile "configurators/ssh/error")
|
||||
|
||||
getConfirmSshR :: SshData -> Handler RepHtml
|
||||
getConfirmSshR :: SshData -> Handler Html
|
||||
getConfirmSshR sshdata = sshConfigurator $
|
||||
$(widgetFile "configurators/ssh/confirm")
|
||||
|
||||
|
|
@ -273,13 +273,13 @@ getRetrySshR sshdata = do
|
|||
s <- liftIO $ testServer $ mkSshInput sshdata
|
||||
redirect $ either (const $ ConfirmSshR sshdata) ConfirmSshR s
|
||||
|
||||
getMakeSshGitR :: SshData -> Handler RepHtml
|
||||
getMakeSshGitR :: SshData -> Handler Html
|
||||
getMakeSshGitR = makeSsh False setupGroup
|
||||
|
||||
getMakeSshRsyncR :: SshData -> Handler RepHtml
|
||||
getMakeSshRsyncR :: SshData -> Handler Html
|
||||
getMakeSshRsyncR = makeSsh True setupGroup
|
||||
|
||||
makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
|
||||
makeSsh :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
|
||||
makeSsh rsync setup sshdata
|
||||
| needsPubKey sshdata = do
|
||||
keypair <- liftIO genSshKeyPair
|
||||
|
|
@ -290,7 +290,7 @@ makeSsh rsync setup sshdata
|
|||
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
|
||||
sshSetup [sshhost, remoteCommand] "" $
|
||||
makeSshRepo rsync setup sshdata
|
||||
|
|
@ -307,15 +307,15 @@ makeSsh' rsync setup origsshdata sshdata keypair = do
|
|||
else Nothing
|
||||
]
|
||||
|
||||
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
|
||||
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler Html
|
||||
makeSshRepo forcersync setup sshdata = do
|
||||
r <- liftAssistant $ makeSshRemote forcersync sshdata Nothing
|
||||
setup r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
||||
getAddRsyncNetR :: Handler RepHtml
|
||||
getAddRsyncNetR :: Handler Html
|
||||
getAddRsyncNetR = postAddRsyncNetR
|
||||
postAddRsyncNetR :: Handler RepHtml
|
||||
postAddRsyncNetR :: Handler Html
|
||||
postAddRsyncNetR = do
|
||||
((result, form), enctype) <- runFormPost $
|
||||
renderBootstrap $ sshInputAForm hostnamefield $
|
||||
|
|
@ -343,7 +343,7 @@ postAddRsyncNetR = do
|
|||
user name something like "7491"
|
||||
|]
|
||||
|
||||
makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml
|
||||
makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler Html
|
||||
makeRsyncNet sshinput reponame setup = do
|
||||
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
|
||||
keypair <- liftIO $ genSshKeyPair
|
||||
|
|
|
|||
|
|
@ -26,10 +26,10 @@ import qualified Data.Map as M
|
|||
import qualified Data.Text as T
|
||||
import Network.URI
|
||||
|
||||
webDAVConfigurator :: Widget -> Handler RepHtml
|
||||
webDAVConfigurator :: Widget -> Handler Html
|
||||
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)
|
||||
|
||||
data WebDAVInput = WebDAVInput
|
||||
|
|
@ -59,9 +59,9 @@ webDAVCredsAForm defcreds = WebDAVInput
|
|||
<*> pure T.empty
|
||||
<*> pure NoEncryption -- not used!
|
||||
|
||||
getAddBoxComR :: Handler RepHtml
|
||||
getAddBoxComR :: Handler Html
|
||||
getAddBoxComR = postAddBoxComR
|
||||
postAddBoxComR :: Handler RepHtml
|
||||
postAddBoxComR :: Handler Html
|
||||
#ifdef WITH_WEBDAV
|
||||
postAddBoxComR = boxConfigurator $ do
|
||||
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
|
||||
|
|
@ -87,9 +87,9 @@ postAddBoxComR = boxConfigurator $ do
|
|||
postAddBoxComR = error "WebDAV not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableWebDAVR :: UUID -> Handler RepHtml
|
||||
getEnableWebDAVR :: UUID -> Handler Html
|
||||
getEnableWebDAVR = postEnableWebDAVR
|
||||
postEnableWebDAVR :: UUID -> Handler RepHtml
|
||||
postEnableWebDAVR :: UUID -> Handler Html
|
||||
#ifdef WITH_WEBDAV
|
||||
postEnableWebDAVR uuid = do
|
||||
m <- liftAnnex readRemoteLog
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ getBuddyName u = go =<< getclientjid
|
|||
<$> getDaemonStatus
|
||||
#endif
|
||||
|
||||
getNeedCloudRepoR :: UUID -> Handler RepHtml
|
||||
getNeedCloudRepoR :: UUID -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
|
||||
buddyname <- liftAssistant $ getBuddyName for
|
||||
|
|
@ -89,25 +89,25 @@ getNeedCloudRepoR _ = xmppPage $
|
|||
$(widgetFile "configurators/xmpp/disabled")
|
||||
#endif
|
||||
|
||||
getXMPPConfigR :: Handler RepHtml
|
||||
getXMPPConfigR :: Handler Html
|
||||
getXMPPConfigR = postXMPPConfigR
|
||||
|
||||
postXMPPConfigR :: Handler RepHtml
|
||||
postXMPPConfigR :: Handler Html
|
||||
postXMPPConfigR = xmppform DashboardR
|
||||
|
||||
getXMPPConfigForPairFriendR :: Handler RepHtml
|
||||
getXMPPConfigForPairFriendR :: Handler Html
|
||||
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
|
||||
|
||||
postXMPPConfigForPairFriendR :: Handler RepHtml
|
||||
postXMPPConfigForPairFriendR :: Handler Html
|
||||
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
|
||||
|
||||
getXMPPConfigForPairSelfR :: Handler RepHtml
|
||||
getXMPPConfigForPairSelfR :: Handler Html
|
||||
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
|
||||
|
||||
postXMPPConfigForPairSelfR :: Handler RepHtml
|
||||
postXMPPConfigForPairSelfR :: Handler Html
|
||||
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
|
||||
|
||||
xmppform :: Route WebApp -> Handler RepHtml
|
||||
xmppform :: Route WebApp -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
xmppform next = xmppPage $ do
|
||||
((result, form), enctype) <- liftH $ do
|
||||
|
|
@ -133,12 +133,12 @@ xmppform _ = xmppPage $
|
|||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-}
|
||||
getBuddyListR :: NotificationId -> Handler RepHtml
|
||||
getBuddyListR :: NotificationId -> Handler Html
|
||||
getBuddyListR nid = do
|
||||
waitNotifier getBuddyListBroadcaster nid
|
||||
|
||||
p <- widgetToPageContent buddyListDisplay
|
||||
hamletToRepHtml $ [hamlet|^{pageBody p}|]
|
||||
giveUrlRenderer $ [hamlet|^{pageBody p}|]
|
||||
|
||||
buddyListDisplay :: Widget
|
||||
buddyListDisplay = do
|
||||
|
|
@ -216,5 +216,5 @@ testXMPP creds = do
|
|||
showport (UnixSocket s) = s
|
||||
#endif
|
||||
|
||||
xmppPage :: Widget -> Handler RepHtml
|
||||
xmppPage :: Widget -> Handler Html
|
||||
xmppPage = page "Jabber" (Just Configuration)
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ import Control.Concurrent
|
|||
import System.Posix (getProcessID, signalProcess, sigTERM)
|
||||
import qualified Data.Map as M
|
||||
|
||||
getShutdownR :: Handler RepHtml
|
||||
getShutdownR :: Handler Html
|
||||
getShutdownR = page "Shutdown" Nothing $
|
||||
$(widgetFile "control/shutdown")
|
||||
|
||||
getShutdownConfirmedR :: Handler RepHtml
|
||||
getShutdownConfirmedR :: Handler Html
|
||||
getShutdownConfirmedR = do
|
||||
{- Remove all alerts for currently running activities. -}
|
||||
liftAssistant $ do
|
||||
|
|
@ -45,7 +45,7 @@ getShutdownConfirmedR = do
|
|||
$(widgetFile "control/shutdownconfirmed")
|
||||
|
||||
{- Quite a hack, and doesn't redirect the browser window. -}
|
||||
getRestartR :: Handler RepHtml
|
||||
getRestartR :: Handler Html
|
||||
getRestartR = page "Restarting" Nothing $ do
|
||||
void $ liftIO $ forkIO $ do
|
||||
threadDelay 2000000
|
||||
|
|
@ -63,7 +63,7 @@ getRestartThreadR name = do
|
|||
liftIO $ maybe noop snd $ M.lookup name m
|
||||
redirectBack
|
||||
|
||||
getLogR :: Handler RepHtml
|
||||
getLogR :: Handler Html
|
||||
getLogR = page "Logs" Nothing $ do
|
||||
logfile <- liftAnnex $ fromRepo gitAnnexLogFile
|
||||
logs <- liftIO $ listLogs logfile
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ import Types.Key
|
|||
import qualified Remote
|
||||
import qualified Git
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Text.Hamlet as Hamlet
|
||||
import qualified Data.Map as M
|
||||
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
|
||||
- inserted onto the getDashboardR page.
|
||||
-}
|
||||
getTransfersR :: NotificationId -> Handler RepHtml
|
||||
getTransfersR :: NotificationId -> Handler Html
|
||||
getTransfersR nid = do
|
||||
waitNotifier getTransferBroadcaster nid
|
||||
|
||||
p <- widgetToPageContent $ transfersDisplay False
|
||||
hamletToRepHtml $ [hamlet|^{pageBody p}|]
|
||||
giveUrlRenderer $ [hamlet|^{pageBody p}|]
|
||||
|
||||
{- The main dashboard. -}
|
||||
dashboard :: Bool -> Widget
|
||||
|
|
@ -77,7 +77,7 @@ dashboard warnNoScript = do
|
|||
let transferlist = transfersDisplay warnNoScript
|
||||
$(widgetFile "dashboard/main")
|
||||
|
||||
getDashboardR :: Handler RepHtml
|
||||
getDashboardR :: Handler Html
|
||||
getDashboardR = ifM (inFirstRun)
|
||||
( redirect ConfigurationR
|
||||
, page "" (Just DashBoard) $ dashboard True
|
||||
|
|
@ -88,16 +88,16 @@ headDashboardR :: Handler ()
|
|||
headDashboardR = noop
|
||||
|
||||
{- Same as DashboardR, except no autorefresh at all (and no noscript warning). -}
|
||||
getNoScriptR :: Handler RepHtml
|
||||
getNoScriptR :: Handler Html
|
||||
getNoScriptR = page "" (Just DashBoard) $ dashboard False
|
||||
|
||||
{- Same as DashboardR, except with autorefreshing via meta refresh. -}
|
||||
getNoScriptAutoR :: Handler RepHtml
|
||||
getNoScriptAutoR :: Handler Html
|
||||
getNoScriptAutoR = page "" (Just DashBoard) $ do
|
||||
let ident = NoScriptR
|
||||
let delayseconds = 3 :: Int
|
||||
let this = NoScriptAutoR
|
||||
toWidgetHead $(hamletFile $ hamletTemplate "dashboard/metarefresh")
|
||||
toWidgetHead $(Hamlet.hamletFile $ hamletTemplate "dashboard/metarefresh")
|
||||
dashboard False
|
||||
|
||||
{- The javascript code does a post. -}
|
||||
|
|
|
|||
|
|
@ -21,12 +21,12 @@ licenseFile = do
|
|||
base <- standaloneAppBase
|
||||
return $ (</> "LICENSE") <$> base
|
||||
|
||||
getAboutR :: Handler RepHtml
|
||||
getAboutR :: Handler Html
|
||||
getAboutR = page "About git-annex" (Just About) $ do
|
||||
builtinlicense <- isJust <$> liftIO licenseFile
|
||||
$(widgetFile "documentation/about")
|
||||
|
||||
getLicenseR :: Handler RepHtml
|
||||
getLicenseR :: Handler Html
|
||||
getLicenseR = do
|
||||
v <- liftIO licenseFile
|
||||
case v of
|
||||
|
|
@ -37,6 +37,6 @@ getLicenseR = do
|
|||
license <- liftIO $ readFile f
|
||||
$(widgetFile "documentation/license")
|
||||
|
||||
getRepoGroupR :: Handler RepHtml
|
||||
getRepoGroupR :: Handler Html
|
||||
getRepoGroupR = page "About repository groups" (Just About) $ do
|
||||
$(widgetFile "documentation/repogroup")
|
||||
|
|
|
|||
|
|
@ -23,7 +23,6 @@ import Assistant.Types.Buddies
|
|||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
#ifndef WITH_OLD_YESOD
|
||||
|
|
|
|||
|
|
@ -18,11 +18,10 @@ import Config.Files
|
|||
import qualified Utility.Url as Url
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Control.Concurrent
|
||||
import System.Process (cwd)
|
||||
|
||||
getRepositorySwitcherR :: Handler RepHtml
|
||||
getRepositorySwitcherR :: Handler Html
|
||||
getRepositorySwitcherR = page "Switch repository" Nothing $ do
|
||||
repolist <- liftIO listOtherRepos
|
||||
$(widgetFile "control/repositoryswitcher")
|
||||
|
|
@ -40,7 +39,7 @@ listOtherRepos = do
|
|||
- 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 :: FilePath -> Handler Html
|
||||
getSwitchToRepositoryR repo = do
|
||||
liftIO $ startAssistant repo
|
||||
liftIO $ addAutoStartFile repo -- make this the new default repo
|
||||
|
|
|
|||
|
|
@ -15,8 +15,7 @@ import Assistant.WebApp.Types
|
|||
import Assistant.WebApp.SideBar
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Text.Hamlet
|
||||
import qualified Text.Hamlet as Hamlet
|
||||
import Data.Text (Text)
|
||||
|
||||
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
|
||||
- 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
|
||||
setTitle title
|
||||
sideBarDisplay
|
||||
content
|
||||
|
||||
{- 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
|
||||
webapp <- getYesod
|
||||
navbar <- map navdetails <$> selectNavBar
|
||||
|
|
@ -62,7 +61,7 @@ customPage navbaritem content = do
|
|||
addScript $ StaticR js_bootstrap_modal_js
|
||||
addScript $ StaticR js_bootstrap_collapse_js
|
||||
$(widgetFile "page")
|
||||
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
|
||||
giveUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
|
||||
where
|
||||
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
|
||||
|
||||
|
|
|
|||
|
|
@ -79,11 +79,11 @@ notWanted _ = False
|
|||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-}
|
||||
getRepoListR :: RepoListNotificationId -> Handler RepHtml
|
||||
getRepoListR :: RepoListNotificationId -> Handler Html
|
||||
getRepoListR (RepoListNotificationId nid reposelector) = do
|
||||
waitNotifier getRepoListBroadcaster nid
|
||||
p <- widgetToPageContent $ repoListDisplay reposelector
|
||||
hamletToRepHtml $ [hamlet|^{pageBody p}|]
|
||||
giveUrlRenderer $ [hamlet|^{pageBody p}|]
|
||||
|
||||
mainRepoSelector :: RepoSelector
|
||||
mainRepoSelector = RepoSelector
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ import Assistant.DaemonStatus
|
|||
import Utility.NotificationBroadcaster
|
||||
import Utility.Yesod
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
|
@ -61,7 +60,7 @@ sideBarDisplay = do
|
|||
- body is. To get the widget head content, the widget is also
|
||||
- inserted onto all pages.
|
||||
-}
|
||||
getSideBarR :: NotificationId -> Handler RepHtml
|
||||
getSideBarR :: NotificationId -> Handler Html
|
||||
getSideBarR nid = do
|
||||
waitNotifier getAlertBroadcaster nid
|
||||
|
||||
|
|
@ -73,7 +72,7 @@ getSideBarR nid = do
|
|||
liftIO $ threadDelay 100000
|
||||
|
||||
page <- widgetToPageContent sideBarDisplay
|
||||
hamletToRepHtml $ [hamlet|^{pageBody page}|]
|
||||
giveUrlRenderer $ [hamlet|^{pageBody page}|]
|
||||
|
||||
{- Called by the client to close an alert. -}
|
||||
getCloseAlert :: AlertId -> Handler ()
|
||||
|
|
|
|||
|
|
@ -23,7 +23,6 @@ import Utility.Yesod
|
|||
import Logs.Transfer
|
||||
import Build.SysConfig (packageversion)
|
||||
|
||||
import Yesod
|
||||
import Yesod.Static
|
||||
import Text.Hamlet
|
||||
import Data.Text (Text, pack, unpack)
|
||||
|
|
@ -72,7 +71,7 @@ instance Yesod WebApp where
|
|||
addStylesheet $ StaticR css_bootstrap_css
|
||||
addStylesheet $ StaticR css_bootstrap_responsive_css
|
||||
$(widgetFile "error")
|
||||
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
|
||||
giveUrlRenderer $(hamletFile $ hamletTemplate "bootstrap")
|
||||
|
||||
instance RenderMessage WebApp FormMessage where
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
|
|
|
|||
|
|
@ -10,18 +10,28 @@
|
|||
|
||||
{-# 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_default(1,2,0)
|
||||
import Yesod.Core
|
||||
#if MIN_VERSION_yesod(1,2,0)
|
||||
import Yesod as Y
|
||||
#else
|
||||
import Yesod as Y hiding (Html)
|
||||
#endif
|
||||
#ifndef __ANDROID__
|
||||
import Yesod.Default.Util
|
||||
import Language.Haskell.TH.Syntax (Q, Exp)
|
||||
#if MIN_VERSION_yesod_default(1,1,0)
|
||||
import Data.Default (def)
|
||||
import Text.Hamlet
|
||||
import Text.Hamlet hiding (Html)
|
||||
#endif
|
||||
|
||||
widgetFile :: String -> Q Exp
|
||||
|
|
@ -47,3 +57,11 @@ liftH = handlerToWidget
|
|||
liftH :: MonadLift base m => base a -> m a
|
||||
liftH = lift
|
||||
#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
|
||||
|
|
|
|||
Loading…
Reference in a new issue