diff options
Diffstat (limited to 'Assistant/WebApp/Types.hs')
-rw-r--r-- | Assistant/WebApp/Types.hs | 98 |
1 files changed, 0 insertions, 98 deletions
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs deleted file mode 100644 index 4198cd428..000000000 --- a/Assistant/WebApp/Types.hs +++ /dev/null @@ -1,98 +0,0 @@ -{- git-annex assistant webapp types - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Assistant.WebApp.Types where - -import Assistant.Common -import Assistant.Ssh -import Assistant.ThreadedMonad -import Assistant.DaemonStatus -import Assistant.ScanRemotes -import Assistant.TransferQueue -import Assistant.TransferSlots -import Assistant.Alert -import Assistant.Pairing -import Utility.NotificationBroadcaster -import Utility.WebApp -import Logs.Transfer - -import Yesod -import Yesod.Static -import Data.Text (Text, pack, unpack) -import Control.Concurrent.STM - -staticFiles "static" - -mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") - -data WebApp = WebApp - { threadState :: Maybe ThreadState - , daemonStatus :: DaemonStatusHandle - , scanRemotes :: ScanRemoteMap - , transferQueue :: TransferQueue - , transferSlots :: TransferSlots - , secretToken :: Text - , relDir :: Maybe FilePath - , getStatic :: Static - , webAppState :: TMVar WebAppState - , postFirstRun :: Maybe (IO String) - } - -instance Yesod WebApp where - {- Require an auth token be set when accessing any (non-static route) -} - isAuthorized _ _ = checkAuthToken secretToken - - {- Add the auth token to every url generated, except static subsite - - urls (which can show up in Permission Denied pages). -} - joinPath = insertAuthToken secretToken excludeStatic - where - excludeStatic [] = True - excludeStatic (p:_) = p /= "static" - - makeSessionBackend = webAppSessionBackend - jsLoader _ = BottomOfHeadBlocking - -instance RenderMessage WebApp FormMessage where - renderMessage _ _ = defaultFormMessage - -type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget) - -data WebAppState = WebAppState - { showIntro :: Bool -- should the into message be displayed? - , otherRepos :: [(String, String)] -- name and path to other repos - } - -instance PathPiece SshData where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece NotificationId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece AlertId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece Transfer where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece PairMsg where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece SecretReminder where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece UUID where - toPathPiece = pack . show - fromPathPiece = readish . unpack |