diff options
| -rw-r--r-- | Assistant.hs | 8 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 43 | ||||
| -rw-r--r-- | Makefile | 20 | ||||
| -rw-r--r-- | Utility/WebApp.hs | 104 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/design/assistant/webapp.mdwn | 2 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 6 | ||||
| -rw-r--r-- | doc/install.mdwn | 2 | ||||
| -rw-r--r-- | git-annex.cabal | 13 |
9 files changed, 189 insertions, 10 deletions
diff --git a/Assistant.hs b/Assistant.hs index 0049d3177..de996aa74 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -88,6 +88,8 @@ - are indicated by writing to this TMVar. -} +{-# LANGUAGE CPP #-} + module Assistant where import Assistant.Common @@ -108,6 +110,9 @@ import Assistant.Threads.Transferrer import Assistant.Threads.SanityChecker import Assistant.Threads.MountWatcher import Assistant.Threads.TransferScanner +#ifdef WITH_WEBAPP +import Assistant.Threads.WebApp +#endif import qualified Utility.Daemon import Utility.LogFile import Utility.ThreadScheduler @@ -146,6 +151,9 @@ startDaemon assistant foreground , sanityCheckerThread st dstatus transferqueue changechan , mountWatcherThread st dstatus scanremotes , transferScannerThread st scanremotes transferqueue +#ifdef WITH_WEBAPP + , webAppThread dstatus +#endif , watchThread st dstatus transferqueue changechan ] debug "assistant" diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs new file mode 100644 index 000000000..1d9d3cc2f --- /dev/null +++ b/Assistant/Threads/WebApp.hs @@ -0,0 +1,43 @@ +{- git-annex assistant webapp + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-} + +module Assistant.Threads.WebApp where + +import Assistant.Common +import Assistant.DaemonStatus +import Utility.WebApp + +import Yesod + +data WebApp = WebApp DaemonStatusHandle + +mkYesod "WebApp" [parseRoutes| +/ HomeR GET +/config ConfigR GET +|] + +instance Yesod WebApp + +getHomeR :: Handler RepHtml +getHomeR = defaultLayout [whamlet|Hello, World<p><a href=@{ConfigR}>config|] + +getConfigR :: Handler RepHtml +getConfigR = defaultLayout [whamlet|<a href=@{HomeR}>main|] + +webAppThread :: DaemonStatusHandle -> IO () +webAppThread dstatus = do + app <- toWaiApp (WebApp dstatus) + app' <- ifM debugEnabled + ( return $ httpDebugLogger app + , return app + ) + runWebApp app' browser + where + browser p = void $ + runBrowser $ "http://" ++ localhost ++ ":" ++ show p @@ -1,19 +1,23 @@ +CFLAGS=-Wall +IGNORE=-ignore-package monads-fd -ignore-package monads-tf +BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility +FEATURES=-DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP + bins=git-annex mans=git-annex.1 git-annex-shell.1 sources=Build/SysConfig.hs Utility/Touch.hs Utility/Mounts.hs all=$(bins) $(mans) docs -CFLAGS=-Wall - OS:=$(shell uname | sed 's/[-_].*//') ifeq ($(OS),Linux) -BASEFLAGS_OPTS=-DWITH_INOTIFY -DWITH_DBUS +OPTFLAGS=-DWITH_INOTIFY -DWITH_DBUS clibs=Utility/libdiskfree.o Utility/libmounts.o else # BSD system -BASEFLAGS_OPTS=-DWITH_KQUEUE +OPTFLAGS=-DWITH_KQUEUE clibs=Utility/libdiskfree.o Utility/libmounts.o Utility/libkqueue.o ifeq ($(OS),Darwin) +OPTFLAGS=-DWITH_KQUEUE -DOSX # Ensure OSX compiler builds for 32 bit when using 32 bit ghc GHCARCH:=$(shell ghc -e 'print System.Info.arch') ifeq ($(GHCARCH),i386) @@ -23,12 +27,10 @@ endif endif PREFIX=/usr -IGNORE=-ignore-package monads-fd -ignore-package monads-tf -BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS) -GHCFLAGS=-O2 $(BASEFLAGS) +GHCFLAGS=-O2 $(BASEFLAGS) $(FEATURES) ifdef PROFILE -GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) +GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) $(FEATURES) $(OPTFLAGS) endif GHCMAKE=ghc $(GHCFLAGS) --make @@ -43,7 +45,7 @@ all: $(all) sources: $(sources) # Disables optimisation. Not for production use. -fast: GHCFLAGS=$(BASEFLAGS) +fast: GHCFLAGS=$(BASEFLAGS) $(FEATURES) $(OPTFLAGS) fast: $(bins) Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs new file mode 100644 index 000000000..614a57cea --- /dev/null +++ b/Utility/WebApp.hs @@ -0,0 +1,104 @@ +{- WAI webapp + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, CPP #-} + +module Utility.WebApp where + +import Common + +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Logger +import Control.Monad.IO.Class +import Network.HTTP.Types +import System.Log.Logger +import Data.ByteString.Lazy.UTF8 +import Data.ByteString.Lazy +import Data.CaseInsensitive as CI +import Network.Socket +import Control.Exception + +localhost :: String +localhost = "localhost" + +{- Runs a web browser on a given url. + - + - Note: The url *will* be visible to an attacker. -} +runBrowser :: String -> IO Bool +runBrowser url = boolSystem cmd [Param url] + where +#if MAC + cmd = "open" +#else + cmd = "xdg-open" +#endif + +{- Binds to a socket on localhost, and runs a webapp on it. + - + - An IO action can also be run, to do something with the port number, + - such as start a web browser to view the webapp. + -} +runWebApp :: Application -> (PortNumber -> IO ()) -> IO () +runWebApp app observer = do + sock <- localSocket + observer =<< socketPort sock + runSettingsSocket defaultSettings sock app + +{- Binds to a local socket, selecting any free port. + - + - As a (very weak) form of security, only connections from + - localhost are accepted. -} +localSocket :: IO Socket +localSocket = do + addrs <- getAddrInfo (Just hints) (Just localhost) Nothing + go $ Prelude.head addrs + where + hints = defaultHints + { addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV] + , addrSocketType = Stream + } + go addr = bracketOnError (open addr) close (use addr) + open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + close = sClose + use addr sock = do + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress addr) + listen sock maxListenQueue + return sock + +{- Checks if debugging is actually enabled. -} +debugEnabled :: IO Bool +debugEnabled = do + l <- getRootLogger + return $ getLevel l <= Just DEBUG + +{- WAI middleware that logs using System.Log.Logger at debug level. + - + - Recommend only inserting this middleware when debugging is actually + - enabled, as it's not optimised at all. + -} +httpDebugLogger :: Middleware +httpDebugLogger waiApp req = do + logRequest req + waiApp req + +logRequest :: MonadIO m => Request -> m () +logRequest req = do + liftIO $ debugM "WebApp" $ unwords + [ showSockAddr $ remoteHost req + , frombs $ requestMethod req + , frombs $ rawPathInfo req + --, show $ httpVersion req + --, frombs $ lookupRequestField "referer" req + , frombs $ lookupRequestField "user-agent" req + ] + where + frombs v = toString $ fromChunks [v] + +lookupRequestField :: CI Ascii -> Request -> Ascii +lookupRequestField k req = fromMaybe "" . lookup k $ requestHeaders req diff --git a/debian/control b/debian/control index 35cbfde05..c7531cd3f 100644 --- a/debian/control +++ b/debian/control @@ -23,6 +23,7 @@ Build-Depends: libghc-hinotify-dev [linux-any], libghc-stm-dev (>= 2.3), libghc-dbus-dev, + libghc-yesod-dev, ikiwiki, perlmagick, git, diff --git a/doc/design/assistant/webapp.mdwn b/doc/design/assistant/webapp.mdwn index 598c1ff3a..cec766c57 100644 --- a/doc/design/assistant/webapp.mdwn +++ b/doc/design/assistant/webapp.mdwn @@ -2,7 +2,7 @@ The webapp is a web server that displays a shiny interface. ## security -* Listen only to localhost. +* Listen only to localhost. **done** * Instruct the user's web browser to open an url that contains a secret token. This guards against other users on the same system. * I would like to avoid passwords or other authentication methods, diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 85a5a18f0..282b1fda5 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -188,6 +188,12 @@ subdirectories). * assistant Like watch, but also automatically syncs changes to other remotes. + Typically started at boot, or when you log in. + +* webapp + + Opens a web browser, viewing the git-annex assistant's web app. + (If the assistant is not already running, it will be automatically started.) # REPOSITORY SETUP COMMANDS diff --git a/doc/install.mdwn b/doc/install.mdwn index 54d6ecb6b..058c3cf6e 100644 --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -48,6 +48,8 @@ To build and use git-annex, you will need: (optional; Linux only) * [dbus](http://hackage.haskell.org/package/dbus) (optional) + * [yesod](http://hackage.haskell.org/package/yesod) + (optional; for webapp) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) diff --git a/git-annex.cabal b/git-annex.cabal index 2e312d4c3..11412d19a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -37,6 +37,9 @@ Flag Dbus Flag Assistant Description: Enable git-annex assistant and watch command +Flag Webapp + Description: Enable git-annex webapp + Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, @@ -61,11 +64,21 @@ Executable git-annex if os(linux) && flag(Inotify) Build-Depends: hinotify CPP-Options: -DWITH_INOTIFY + else + if (! os(windows)) + CPP-Options: -DWITH_KQUEUE if flag(Dbus) Build-Depends: dbus CPP-Options: -DWITH_DBUS + if flag(Webapp) + Build-Depends: yesod + CPP-Options: -DWITH_WEBAPP + + if (os(darwin)) + CPP-Options: -DOSX + Test-Suite test Type: exitcode-stdio-1.0 Main-Is: test.hs |