run yesod, and launch webapp on startup

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"

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

Makefile

@@ -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

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

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,

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,

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
 

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/)

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