diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,31 @@
+Copyright (c) 2010, Jinjing Wang
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Jinjing Wang nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Nemesis b/Nemesis
new file mode 100644
--- /dev/null
+++ b/Nemesis
@@ -0,0 +1,39 @@
+
+nemesis = do
+
+ clean
+ [ "**/*.hi"
+ , "**/*.o"
+ , "manifest"
+ , "repo/**"
+ , "public/repo/**"
+ , ".bin/*"
+ ]
+
+ desc "prepare cabal dist"
+ task "dist" - do
+ sh "cabal clean"
+ sh "cabal configure"
+ sh "cabal sdist"
+
+
+ desc "server console"
+ task "is" - do
+ sh "ghci -isrc src/CodeMushu/Driver/Server.hs"
+
+
+
+ desc "client console"
+ task "ic" - do
+ sh "ghci -isrc src/CodeMushu/Driver/Client.hs"
+
+ desc "prep-db"
+ task "prep-db" - do
+ sh "mkdir -p public/repo/download"
+
+
+ desc "run server"
+ task "rs" - do
+ sh "mkdir -p .bin"
+ sh "ghc --make -O2 -threaded -isrc src/CodeMushu/Driver/Server.hs -o .bin/server"
+ sh ".bin/server"
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> main = defaultMain
diff --git a/readme.md b/readme.md
new file mode 100644
--- /dev/null
+++ b/readme.md
@@ -0,0 +1,23 @@
+Source Code Server
+==================
+
+The server backend for the [source code iPhone app](http://itunes.com/apps/sourcecode) (iTunes link).
+
+Code is not clean as it's for reference only :)
+
+Bird view architecture
+======================
+
+* client requests code
+* server fetches code via http from remote repository
+* server reformats code to sqlite database
+* server tells the client ready to fetch
+* client fetches code via http (gzip compressed)
+
+Licensed under BSD
+==================
+
+
+
+
+
diff --git a/source-code-server.cabal b/source-code-server.cabal
new file mode 100644
--- /dev/null
+++ b/source-code-server.cabal
@@ -0,0 +1,61 @@
+Name: source-code-server
+Version: 2010.9.1
+Build-type: Simple
+Synopsis: The server backend for the source code iPhone app
+Description: a reference implementation, such that an android equivalent is less of work
+
+License: BSD3
+License-file: LICENSE
+Author: Jinjing Wang
+Maintainer: Jinjing Wang
+Build-Depends: base
+Cabal-version: >= 1.2
+category: Web
+homepage: http://github.com/nfjinjing/source-code-server
+data-files: readme.md, Nemesis
+
+Executable source-code-server
+ ghc-options: -Wall
+ build-depends: base >= 4 && < 5
+ , haskell98
+ , mtl
+ , process
+ , containers
+ , mps
+ , json
+ , directory
+ , hack
+ , hack-contrib
+ , hack-handler-happstack
+ , data-default
+ , stm
+ , loli
+ , StateVar
+ , bytestring
+ , unix
+ , curl
+ , filepath
+ , template-haskell
+ , safe
+ , time
+ , HDBC-sqlite3
+ , HDBC
+
+ hs-source-dirs: src/
+ main-is: CodeMushu/Driver/Server.hs
+ other-modules: CodeMushu.Constant
+ CodeMushu.DSL
+ CodeMushu.Env
+ CodeMushu.Project
+ CodeMushu.Repo
+ CodeMushu.Server
+ CodeMushu.Thread
+ CodeMushu.Type
+
+ MPS.Lab1
+ Rika.Type.Default
+
+
+ Rika.Data.Record.Label
+ Rika.Data.Record.Label.TH
+
diff --git a/src/CodeMushu/Constant.hs b/src/CodeMushu/Constant.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Constant.hs
@@ -0,0 +1,45 @@
+module CodeMushu.Constant where
+
+import CodeMushu.Type
+import CodeMushu.Thread
+
+import Rika.Type.Default
+
+
+dummy_cb :: StatusCallback
+dummy_cb x = return () -- jailed (print x)
+
+dummy_git_repo :: String
+dummy_git_repo = "~/scm/git/iphone2/matrix-mushu"
+
+dummy_hg_repo :: String
+dummy_hg_repo = "~/scm/hg/pip"
+
+dummy_darcs_repo:: String
+dummy_darcs_repo = "~/scm/darcs/haskell/darcsden"
+
+dummy_raw_repo:: String
+dummy_raw_repo = "http://code.jquery.com/jquery-1.4.2.min.js"
+
+dummy_archive_repo:: String
+dummy_archive_repo = "http://funkymic.com/pri/source-code/loli.tgz"
+
+dummy_svn_repo:: String
+dummy_svn_repo = "http://syntaxhighlighter.googlecode.com/svn/trunk/"
+
+
+dummy_good_project :: Project
+dummy_good_project = def
+ {
+ project_id = 0
+ , project_name = "dummy_good"
+ , project_url = "http://dummy-good.git"
+ }
+
+dummy_bad_project :: Project
+dummy_bad_project = def
+ {
+ project_id = 1
+ , project_name = "dummy_bad"
+ , project_url = "http://dummy-bad.git"
+ }
diff --git a/src/CodeMushu/DSL.hs b/src/CodeMushu/DSL.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/DSL.hs
@@ -0,0 +1,12 @@
+module CodeMushu.DSL where
+
+import CodeMushu.Type
+
+import Data.StateVar
+
+import MPS.Env hiding (read)
+import Prelude ()
+
+read :: (HasGetter g) => g a -> IO a
+read = get
+
diff --git a/src/CodeMushu/Driver/Server.hs b/src/CodeMushu/Driver/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Driver/Server.hs
@@ -0,0 +1,46 @@
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import CodeMushu.Env
+
+import Prelude ()
+
+import Hack.Contrib.Utils (escape_html)
+import MPS.Extra
+
+
+import CodeMushu.Repo
+
+import CodeMushu.Server
+-- import Hack.Handler.SimpleServer
+import Hack.Handler.Happstack
+
+import Control.Concurrent.STM
+import qualified Data.Map as M
+import Hack.Contrib.Middleware.Inspect
+import Hack.Contrib.Utils
+import Hack.Contrib.Response (set_content_type)
+import qualified Data.Default as Default
+
+middleware_stack =
+ [
+ -- inspect
+ \app env -> jailed (putStrLn (env.path_info)) >> app env
+ , text_sqlite
+ ]
+
+text_sqlite app = \env ->
+ if env.path_info.starts_with "/repo/download/"
+ then do
+ r <- app env
+ return - r.set_content_type "text/sqlite"
+ else app env
+
+run' = runWithConfig Default.def {port = 6001}
+
+main = do
+ putStrLn - "server started..."
+
+ repo_state <- newTVarIO def
+ run' - use middleware_stack - code_mushu_app repo_state
+
+
diff --git a/src/CodeMushu/Env.hs b/src/CodeMushu/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Env.hs
@@ -0,0 +1,32 @@
+module CodeMushu.Env
+(
+ module MPS.Env
+, module CodeMushu.Type
+, module Rika.Type.Default
+, module CodeMushu.Constant
+, module CodeMushu.Thread
+, module MPS.Lab1
+, module Rika.Data.Record.Label
+, module Safe
+, module CodeMushu.DSL
+, module System.FilePath
+, module Text.JSON.Generic
+, module System.Directory
+, module Data.IORef
+)
+where
+
+
+import MPS.Env hiding (log, at, drop, length, mod, read, FilePath)
+import CodeMushu.Type
+import Rika.Type.Default
+import CodeMushu.Constant
+import CodeMushu.Thread
+import MPS.Lab1
+import Rika.Data.Record.Label hiding ((<->), get)
+import Safe (readMay)
+import CodeMushu.DSL
+import System.FilePath
+import Text.JSON.Generic (encodeJSON, decodeJSON)
+import System.Directory
+import Data.IORef
diff --git a/src/CodeMushu/Project.hs b/src/CodeMushu/Project.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Project.hs
@@ -0,0 +1,23 @@
+module CodeMushu.Project where
+
+import CodeMushu.Env
+import Prelude ()
+
+
+in_project :: String -> Project -> String
+in_project x p = "repo" / p.project_id.show / x
+
+project_root_path :: Project -> String
+project_root_path p = "repo" / p.project_id.show
+
+project_db_path :: Project -> String
+project_db_path = in_project "db"
+
+project_db_file :: Project -> String
+project_db_file = project_db_path > (/ "code.db")
+
+project_source_path :: Project -> String
+project_source_path = in_project "src"
+
+project_bounce_file :: Project -> String
+project_bounce_file p = "public/repo/download" / p.project_id.show + ".sqlite"
diff --git a/src/CodeMushu/Repo.hs b/src/CodeMushu/Repo.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Repo.hs
@@ -0,0 +1,426 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, NamedFieldPuns #-}
+
+
+module CodeMushu.Repo where
+
+
+import CodeMushu.Env
+import Prelude ()
+
+import System.Process
+import Data.List hiding (length)
+
+import qualified Data.ByteString.Char8 as B
+
+import Control.Monad hiding (join)
+import System.Posix hiding (sleep)
+
+import Data.Map (Map)
+
+import System.FilePath
+
+import Database.HDBC
+import Database.HDBC.Sqlite3
+
+import MPS.TH
+import MPS.Extra
+import MPSUTF8 (mkdir_p, rm_rf)
+import System.Directory
+
+import Control.Concurrent.STM
+import GHC.IO.Exception
+
+import qualified Prelude as P
+
+import CodeMushu.Project
+
+import Network.Curl hiding (content)
+
+is_text :: String -> IO Bool
+is_text x = do
+ r <- readProcess "file" ["-b", x] ""
+
+ return - "text" `isInfixOf` r
+
+is_image :: String -> Bool
+is_image =
+ let image_extensions = [".png", ".jpg"]
+ in
+
+ takeExtension > belongs_to image_extensions
+
+not_too_big :: String -> IO Bool
+not_too_big = getFileStatus >=> fileSize > (<= limit) > return
+ where
+ limit = _500k
+ _1m = 1000000
+ _500k = 500000
+
+find_source :: StatusCallback -> String -> IO ([String], [String])
+find_source cb path = do
+ cb - DBStage - DBAnalysing
+
+ r <- readProcess "find" [path] ""
+
+ let clean_files = reject (splitPath > has ".svn/")
+ paths = r.lines .clean_files
+
+ files <- paths.filterM (getFileStatus >=> isRegularFile > return)
+ dirs <- paths.filterM (getFileStatus >=> isDirectory > return)
+
+ fs <- files.filterM is_text >>= filterM not_too_big
+
+ let imgs = files.filter is_image
+
+ return - (dirs, fs)
+
+load_code :: String -> String -> IO Code
+load_code _ [] = error "code path can not be empty"
+load_code base x = do
+ let relative_path = makeRelative base x
+ content <- B.readFile x ^ (B.unpack > b2u)
+
+ let tokens = relative_path.splitPath
+ path = relative_path
+ depth = length tokens .from_i
+ parent = if depth.is 1 then "/" else tokens.init.concat
+
+ filesize <- getFileStatus x ^ fileSize ^ from_i
+
+ return - def
+ {
+ path
+ , parent
+ , depth
+ , filesize
+ , content
+ }
+
+load_dir :: String -> String -> IO Code
+load_dir _ [] = error "code path can not be empty"
+load_dir base x = do
+ let relative_path = makeRelative base x
+
+ let tokens = relative_path.splitPath
+ path = relative_path
+ depth = length tokens .from_i
+ parent = if depth.is 1 then "/" else tokens.init.concat
+
+ return - def
+ {
+ path
+ , parent
+ , depth
+ , is_directory = 1
+ }
+
+insert_code :: (IConnection d) => d -> Code -> IO ()
+insert_code db code = do
+ let { vals =
+
+ [ toSql - code.path
+ , toSql - code.parent
+ , toSql - code.depth
+ , toSql - code.filesize
+ , toSql - code.content
+ , toSql - code.is_directory
+ ]
+
+ }
+
+
+ -- withTransaction db - \d -> run d insert_sql vals
+ run db insert_sql vals
+
+ -- log - "inserted " + code.path
+
+ -- [[uid]] <- quickQuery db "select last_insert_rowid()" []
+
+ -- return (fromSql uid)
+
+ return ()
+
+
+insert_code_from_path :: (IConnection d) => d -> String -> String -> IO ()
+insert_code_from_path db base x = load_code base x >>= insert_code db
+
+insert_dir_from_path :: (IConnection d) => d -> String -> String -> IO ()
+insert_dir_from_path db base x = load_dir base x >>= insert_code db
+
+init_db :: StatusCallback -> Project -> IO Connection
+init_db cb p = do
+ cb - DBStage - DBInit
+ mkdir_p - p.project_db_path
+
+ db <- handleSqlError - connectSqlite3 - p.project_db_file
+ create_table_if_missing db
+
+ return db
+
+insert_project :: StatusCallback -> Connection -> Project -> IO ()
+insert_project cb db p = do
+ (dirs, source_files) <- find_source cb (p.project_source_path)
+
+ dirs.mapM_ (insert_dir_from_path db (p.project_source_path))
+
+ let total = source_files.length
+
+ int_counter_ref <- newIORef 0
+
+ source_files.indexed.mapM_ ( \(i, path) -> do
+ let progress = i.realToFrac P./ total.realToFrac
+
+ int_counter <- readIORef int_counter_ref
+
+ let int_percent = floor - progress * 100
+
+ when (int_counter P.< int_percent) - do
+ cb - DBStage - DBImporting int_percent
+ writeIORef int_counter_ref int_percent
+
+ insert_code_from_path db (p.project_source_path) path
+ )
+
+create_db :: StatusCallback -> Project -> IO ()
+create_db cb p = do
+ db <- init_db cb p
+
+ insert_project cb db p
+
+ index_db cb db p
+
+ commit db
+
+ release_db cb db p
+
+ return ()
+
+index_db :: StatusCallback -> Connection -> Project -> IO ()
+index_db cb db _ = do
+ cb - DBStage - DBIndexing
+ sql_indecies.lines.reject null.mapM_ (\sql_index -> run db sql_index [])
+ commit db
+
+
+release_db :: StatusCallback -> Connection -> Project -> IO ()
+release_db cb db _ = do
+ cb - DBStage - DBComplete
+ disconnect db
+
+
+
+create_table_if_missing :: (IConnection a) => a -> IO ()
+create_table_if_missing db = do
+ tables <- handleSqlError $ getTables db
+ when (not - "code" `elem` tables) - handleSqlError - do
+ run db sql_schema []
+ commit db
+
+-- repo / project_id / [src|db] | public/repo/project_id.sqlite
+init_project :: Integer -> String -> Repo -> IO Project
+init_project job_id project_url repo = do
+ let project_id = job_id
+ let project_name = project_url.takeFileName
+
+ return - def
+ {
+ project_name
+ , project_id
+ , repo
+ , project_url
+ }
+
+make_project_id :: IO String
+make_project_id = now_in_micro_seconds ^ show
+
+-- get_project_name_from_url = split "/" .last
+unpack_git_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_git_repo cb p = do
+ mkdir_p - p.project_root_path
+
+ cb - UnpackStage - Unpacking
+ exit_code <- rawSystem "git" ["clone", "-q", p.project_url, p.project_source_path]
+
+ when ( exit_code .is ExitSuccess ) - do
+ rm_rf - p.project_source_path / ".git"
+
+ return exit_code
+
+unpack_hg_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_hg_repo cb p = do
+ mkdir_p - p.project_root_path
+
+ cb - UnpackStage - Unpacking
+ exit_code <- rawSystem "hg" ["clone", p.project_url, p.project_source_path]
+
+ when ( exit_code .is ExitSuccess ) - do
+ rm_rf - p.project_source_path / ".hg"
+
+ return exit_code
+
+unpack_darcs_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_darcs_repo cb p = do
+ mkdir_p - p.project_root_path
+
+ cb - UnpackStage - Unpacking
+ exit_code <- rawSystem "darcs" ["get", "--lazy", p.project_url, p.project_source_path]
+
+
+ log - "exit code: " + show exit_code
+
+ when ( exit_code .is ExitSuccess ) - do
+ rm_rf - p.project_source_path / "_darcs"
+
+ return exit_code
+
+validate_repo_url :: String -> IO (Maybe String)
+validate_repo_url url = do
+ (r, xs) <- curlHead url [CurlFollowLocation True]
+
+ return - if r.null.not
+ then
+ case xs.reverse.lookup "Content-Length" >>= readMay of
+ Just i ->
+ -- archive less then 50 MB is valid
+ if i `div` (1024 * 1024) <= 50
+ then
+ Nothing
+ else
+ Just "repo too big"
+ Nothing -> Nothing
+ else
+ Just "invalid url"
+
+
+with_valid_repo :: StatusCallback -> String -> IO ExitCode -> IO ExitCode
+with_valid_repo cb url io = do
+ status <- validate_repo_url - url
+ case status of
+ Nothing -> do
+ io
+
+ Just err -> do
+ cb - Failed - Exception err
+ return - ExitFailure 0
+
+
+unpack_raw_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_raw_repo cb p = do
+ mkdir_p - p.project_source_path
+
+ cb - UnpackStage - Unpacking
+
+ with_valid_repo cb (p.project_url) - do
+ exit_code <- rawSystem "wget" [p.project_url, "--directory-prefix", p.project_source_path]
+ log - "exit code: " + show exit_code
+ return exit_code
+
+unpack_archive_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_archive_repo cb p = do
+ mkdir_p - p.project_source_path
+
+ cb - UnpackStage - Unpacking
+
+ with_valid_repo cb (p.project_url) - do
+ exit_code <- rawSystem "wget" [p.project_url, "--directory-prefix", p.project_source_path]
+ downloads <- ls - p.project_source_path
+ case downloads of
+ [] -> log "could not found downloaded archives"
+ x:_ -> do
+ system - "cd " + p.project_source_path + "; unp " + x
+ removeFile - p.project_source_path / x
+
+ log - "exit code: " + show exit_code
+ return exit_code
+
+unpack_svn_repo :: StatusCallback -> Project -> IO ExitCode
+unpack_svn_repo cb p = do
+ mkdir_p - p.project_root_path
+
+ cb - UnpackStage - Unpacking
+ exit_code <- rawSystem "svn" ["co", "--non-interactive", "-q", p.project_url, p.project_source_path]
+
+
+ log - "exit code: " + show exit_code
+
+ return exit_code
+
+
+unpack_repo :: Repo -> StatusCallback -> Project -> IO ExitCode
+unpack_repo Git = unpack_git_repo
+unpack_repo Darcs = unpack_darcs_repo
+unpack_repo Raw = unpack_raw_repo
+unpack_repo Archive = unpack_archive_repo
+unpack_repo SVN = unpack_svn_repo
+unpack_repo Hg = unpack_hg_repo
+
+bounce_repo :: StatusCallback -> Project -> IO ()
+bounce_repo cb p = do
+ cb Bouncing
+ copyFile (p.project_db_file) (p.project_bounce_file)
+
+cleanup_repo :: StatusCallback -> Project -> IO ()
+cleanup_repo cb p = do
+ cb Cleanup
+
+ -- hack
+ -- fork - do
+ -- sleep 10
+
+ rm_rf - p.project_root_path
+
+create_project :: StatusCallback -> Integer -> Repo -> String -> IO ()
+create_project cb job_id repo x = do
+ p <- init_project job_id x repo
+
+ exit_code <- return_after 30 - unpack_repo repo cb p
+
+ case exit_code of
+ ExitSuccess -> do
+ cb - UnpackStage - UnpackComplete
+ create_db cb p
+ bounce_repo cb p
+ cleanup_repo cb p
+
+ cb - Completed p
+
+ ExitFailure error_code -> do
+ cleanup_repo cb p
+
+ cb - Failed FailedToFetchRepo
+
+
+
+
+-- sql_schema :: String
+sql_schema = [$here|
+
+
+create table code (
+ id INTEGER PRIMARY KEY
+ , path TEXT
+ , parent TEXT
+ , depth INTEGER
+ , filesize INTEGER
+ , content TEXT
+ , is_directory INTEGER
+);
+
+
+|]
+
+sql_indecies = [$here|
+
+create index path_index on code (path);
+create index parent_index on code (parent);
+create index depth_index on code (depth);
+create index is_directory_index on code (is_directory);
+
+|]
+
+
+insert_sql = [$here|
+
+INSERT INTO code(path, parent, depth, filesize, content, is_directory) VALUES(?, ?, ?, ?, ?, ?)
+
+|]
diff --git a/src/CodeMushu/Server.hs b/src/CodeMushu/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Server.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE PackageImports #-}
+
+module CodeMushu.Server where
+
+import CodeMushu.Env
+import Prelude ()
+import CodeMushu.Repo
+
+import Network.Loli
+
+import Text.JSON.Generic
+import Hack.Contrib.Request
+import Hack.Contrib.Response
+import Hack.Contrib.Utils hiding (get)
+
+import "mtl" Control.Monad.Reader
+import "mtl" Control.Monad.State hiding (get)
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Unique
+
+import System.Posix
+
+import Hack (Application)
+
+import Data.ByteString.Lazy.Char8 (pack, unpack)
+
+import Data.StateVar hiding (get)
+
+import qualified Data.Map as M
+
+import Network.Loli.Type
+
+
+test_git_repo = create_project dummy_cb 0 Git dummy_git_repo
+
+test_hg_repo = create_project dummy_cb 0 Hg dummy_hg_repo
+
+test_darcs_repo = create_project dummy_cb 0 Darcs dummy_darcs_repo
+
+test_raw_repo = create_project dummy_cb 0 Raw dummy_raw_repo
+
+test_archive_repo = create_project dummy_cb 0 Archive dummy_archive_repo
+
+test_svn_repo = create_project dummy_cb 0 SVN dummy_svn_repo
+
+gen_id = now_in_micro_seconds
+
+json :: (Data a) => a -> AppUnit
+json x = do
+ modify - set_content_type "application/json"
+ modify - set_body - x.encodeJSON.pack
+
+stateful_callback :: (TVar JobStatus) -> StatusCallback
+stateful_callback state_ref state = do
+ atom - do
+ last_state <- readTVar state_ref
+ case last_state of
+ Failed _ -> return ()
+ _ -> writeTVar state_ref state
+
+ log - show state
+
+test_repo_with_state :: (TVar JobStatus) -> IO ()
+test_repo_with_state ref =
+ create_project (stateful_callback ref) 0 Git dummy_git_repo
+
+user_error x = do
+ text x
+ modify - set_status 500
+
+is_validate_url :: String -> Bool
+is_validate_url x =
+ let
+ repo_formats =
+ [
+ "http://"
+ ]
+ in
+ [
+ repo_formats.any (\f -> x.starts_with f)
+ , not - x.has '@'
+ ]
+ .and
+
+
+code_mushu_app :: (TVar RepoState) -> Application
+code_mushu_app repo_state = loli - do
+
+ public (Just "public") ["/repo/download"]
+
+ get "/repo/create/:repo" - do
+ _params <- ask ^ params
+ _captures <- captures
+
+ case _captures.lookup "repo" >>= readMay of
+ Nothing -> json - JobCreateFailed "unsupported repo format"
+ Just _repo -> do
+ case _params.lookup "url" of
+ Nothing -> json - JobCreateFailed "invalid query format"
+ Just _url -> do
+ let escaped_url = _url.unescape_uri
+
+ if not - escaped_url.is_validate_url
+ then
+ json - JobCreateFailed "invalid protocal"
+ else
+ with_dummy_create escaped_url - do
+
+ io - log - "received request for url: " + escaped_url
+ state_ref <- io - newTVarIO def
+ job_id <- io - now_in_milli_seconds
+
+ io - forkIO -
+ create_project (stateful_callback state_ref) job_id _repo escaped_url
+
+ io - repo_state $~ mod __states_map (M.insert job_id state_ref)
+
+ json - JobCreateSuccess job_id
+
+ get "/repo/query/:job_id" - do
+ _captures <- captures
+
+ case _captures .lookup "job_id" >>= readMay of
+ Nothing -> json - JobQueryFailed "job id is invalid"
+ Just job_id ->
+ with_dummy_query job_id - do
+
+ state <- io - atom - do
+ _map <- readTVar repo_state ^ states_map
+ case _map.M.lookup job_id of
+ Nothing -> return Nothing
+ Just ref -> do
+ readTVar ref ^ Just
+ -- status <- io - read ref
+
+ case state of
+ Nothing -> json - JobQueryFailed "job id doesn't exist"
+ Just _state -> do
+ json - JobQuerySuccess _state
+
+
+
+ get "/" - text "hello world\n"
+
+
+
+with_dummy_query :: Integer -> AppUnit -> AppUnit
+with_dummy_query job_id m
+ | job_id.is (-1) = json - JobQuerySuccess - Completed dummy_good_project
+ | job_id.is (-2) = json - JobQuerySuccess - Failed FailedToFetchRepo
+ | otherwise = m
+
+with_dummy_create :: String -> AppUnit -> AppUnit
+with_dummy_create url m
+ | url.is (dummy_good_project.project_url) = json - JobCreateSuccess (-1)
+ | url.is (dummy_bad_project.project_url) = json - JobCreateSuccess (-2)
+ | otherwise = m
diff --git a/src/CodeMushu/Thread.hs b/src/CodeMushu/Thread.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Thread.hs
@@ -0,0 +1,19 @@
+module CodeMushu.Thread where
+
+import Prelude ()
+import MPS.Env hiding (log)
+import MPS.Extra
+
+import Control.Concurrent
+
+
+sync_lock :: MVar ()
+sync_lock = purify - newMVar ()
+
+jailed :: IO a -> IO a
+jailed io = do
+ withMVar sync_lock (const io)
+
+
+log :: String -> IO ()
+log x = jailed - putStrLn x
diff --git a/src/CodeMushu/Type.hs b/src/CodeMushu/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/CodeMushu/Type.hs
@@ -0,0 +1,265 @@
+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, BangPatterns #-}
+
+module CodeMushu.Type where
+
+import Rika.Type.Default
+
+import Data.Map (Map)
+import Control.Concurrent.STM
+
+import MPS.Env
+import Prelude ()
+
+import Data.StateVar
+import Rika.Data.Record.Label
+
+import Text.JSON.Generic
+
+import Data.ByteString.Char8 (ByteString)
+
+data Code = Code
+ {
+ path :: String
+ , parent :: String
+ , depth :: Integer
+ , filesize :: Integer
+ , content :: String
+ , is_directory :: Integer
+ }
+ deriving (Show, Eq)
+
+instance Default Code where
+ def = Code
+ {
+ path = def
+ , parent = def
+ , depth = 0
+ , filesize = 0
+ , content = def
+ , is_directory = 0
+ }
+
+
+data UnpackStatus =
+ Unpacking
+ | UnpackComplete
+ deriving (Show, Eq, Data, Typeable)
+
+data DBJobStatus =
+ DBInit
+ | DBAnalysing
+ | DBImporting Int
+ | DBIndexing
+ | DBComplete
+ deriving (Show, Eq, Data, Typeable)
+
+data JobError =
+ FailedToFetchRepo
+ | Exception String
+ deriving (Show, Eq, Data, Typeable)
+
+data JobStatus =
+ Initialized
+ | UnpackStage UnpackStatus
+ | DBStage DBJobStatus
+ | Bouncing
+ | Cleanup
+ | Completed Project
+ | Failed JobError
+ deriving (Show, Eq, Data, Typeable)
+
+instance Default JobStatus where
+ def = Initialized
+
+data FetchStatus =
+ FetchInQueue Integer
+ | Fetching JobStatus
+ | FetchFailed String
+
+type StatusCallback = JobStatus -> IO ()
+type FetchCallback = FetchStatus -> IO ()
+type FetchMonitorCallback = IO () -> IO ()
+
+data Repo = Git | Darcs | SVN | Hg | Archive | Raw
+ deriving (Show, Eq, Data, Typeable, Read)
+
+instance Default Repo where
+ def = Git
+
+data Project = Project
+ {
+ project_id :: Integer
+ , project_name :: String
+ , repo :: Repo
+ , project_url :: String
+ }
+ deriving (Show, Eq, Data, Typeable)
+
+instance Default Project where
+ def = Project
+ {
+ project_id = def
+ , project_name = def
+ , repo = def
+ , project_url = def
+ }
+
+data RepoState = RepoState
+ {
+ states_map :: Map Integer (TVar JobStatus)
+ }
+
+instance Default RepoState where
+ def = RepoState
+ {
+ states_map = def
+ }
+
+-- Datatypes
+
+data JobQueryResponse =
+ JobQueryFailed String
+ | JobQuerySuccess JobStatus
+ deriving (Eq, Show, Data, Typeable)
+
+data JobCreateResponse =
+ JobCreateFailed String
+ | JobCreateSuccess Integer
+ deriving (Eq, Show, Data, Typeable)
+
+instance HasGetter TVar where
+ get = atomically < readTVar
+
+instance HasSetter TVar where
+ ($=) x = atomically < writeTVar x
+
+data SourceCode = SourceCode
+ {
+ project_ref :: Project
+ , fetch_status :: FetchStatus
+ }
+
+data ClientState = ClientState
+ {
+ source_codes :: [SourceCode]
+ }
+
+data RepoControlHandle = RepoControlHandle
+ {
+ set_ui_repo_status :: Integer -> LocalRepoStatus -> IO ()
+ , set_global_error :: String -> IO ()
+ }
+
+data RepoControlInput = RepoControlInput
+ {
+ create_repo :: TaskID -> Repo -> String-> IO ()
+ }
+
+{-
+instance Default (Event a) where
+ def = NoEvent
+-}
+
+type TaskID = Int
+type CallbackMap = Map Int RepoControlHandle
+
+data FetchTask =
+ CreateRepo !Repo !ByteString
+ | MonitorRepo !Integer !Integer
+ | DownloadRepo !Integer
+ | NoTask
+ deriving (Show, Eq)
+
+instance Default FetchTask where
+ def = NoTask
+
+data ReactInput = ReactInput
+ {
+ input_id :: !TaskID
+ , fetch_task :: !FetchTask
+ }
+ deriving (Show, Eq)
+
+instance Default ReactInput where
+ def = ReactInput
+ {
+ input_id = 0
+ , fetch_task = def
+ }
+
+data ReactState = ReactState
+ {
+ update_id :: !TaskID
+ , fetch_update :: !FetchUpdate
+ }
+ deriving (Show, Eq)
+
+instance Default ReactState where
+ def = ReactState
+ {
+ update_id = 0
+ , fetch_update = def
+ }
+
+data FetchUpdate =
+ PerformCreateRepo !Repo !ByteString
+ | PerformMonitorRepo !Integer !Integer
+ | PerformDownloadRepo !Integer
+ | SetRepoInQueue
+ | NoUpdate
+ deriving (Show, Eq)
+
+instance Default FetchUpdate where
+ def = NoUpdate
+
+data LocalRepo = LocalRepo
+ {
+ repo_id :: Integer
+ , repo_url :: String
+ , repo_type :: Repo
+ , repo_name :: String
+ , repo_status :: LocalRepoStatus
+ }
+ deriving (Show, Eq, Data, Typeable)
+
+instance Default LocalRepo where
+ def = LocalRepo
+ {
+ repo_id = def
+ , repo_url = def
+ , repo_type = def
+ , repo_name = def
+ , repo_status = def
+ }
+
+data LocalRepoStatus =
+ LocalInQueue
+ | LocalUnpacking
+ | LocalAnalysing
+ | LocalImporting Double
+ | LocalBouncing
+ | LocalDownloading Double
+ | LocalDone
+ | LocalError String
+ | LocalRefreshReachMaximumNumber
+ deriving (Show, Eq, Data, Typeable)
+
+instance Default LocalRepoStatus where
+ def = LocalInQueue
+
+type LocalRepoIndex = Integer
+
+
+{-}
+type FetchIn = Event ReactInput
+type FetchOut = Event ReactState
+type SenseRef = TVar [ReactInput]
+type TaskRef = TVar CallbackMap
+type LocalState = Map LocalRepoIndex LocalRepo
+type LocalStateRef = TVar LocalState
+-}
+
+mkLabels
+ [
+ ''RepoState
+ ]
diff --git a/src/MPS/Lab1.hs b/src/MPS/Lab1.hs
new file mode 100644
--- /dev/null
+++ b/src/MPS/Lab1.hs
@@ -0,0 +1,181 @@
+module MPS.Lab1 where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import MPS.Env hiding (mod, read, length, drop, at)
+import Prelude ()
+
+import Data.Maybe
+import Rika.Type.Default
+
+import qualified Data.StateVar as StateVar
+
+import Data.List ( genericDrop, genericLength )
+import qualified Prelude as P
+
+import Text.JSON.Generic
+import Text.JSON.String
+
+import qualified Control.Monad as Monad
+
+import System.Exit ( exitWith, ExitCode(ExitSuccess) )
+
+import Data.StateVar
+
+import MPS.Extra (now)
+
+import Data.Time.Clock.POSIX
+import System.Exit
+import Data.IORef
+import MPS.Extra
+
+at :: (Show a) => Int -> [a] -> a
+at i xs = if i P.< xs.length
+ then xs !! i
+ else error - show xs ++ " at " ++ show i ++ " failed"
+
+atom :: STM a -> IO a
+atom = atomically
+
+void :: (Monad m) => m a -> m ()
+void x = x >>= const () > return
+
+don't :: (Monad m) => m a -> m ()
+don't = const - return ()
+
+want :: (Monad m, Default b) => (Maybe a) -> (a -> m b) -> m b
+want = flip - maybe (return def)
+
+wantM :: (Monad m, Default b) => m (Maybe a) -> (a -> m b) -> m b
+wantM x f = do
+ x' <- x
+ x'.want - f
+
+length :: (Num i) => [a] -> i
+length = genericLength
+
+drop :: (Integral i) => i -> [a] -> [a]
+drop = genericDrop
+
+to_f :: (Real a, Fractional b) => a -> b
+to_f = realToFrac
+
+sleep :: (RealFrac a) => a -> IO ()
+sleep x = threadDelay - round - (x * 1000000)
+
+append_maybe :: a -> Maybe [a] -> Maybe [a]
+append_maybe x Nothing = Just [x]
+append_maybe x (Just xs) = Just - x:xs
+
+first_or :: a -> [a] -> a
+first_or x xs = case xs of
+ [] -> x
+ (y:_) -> y
+
+maybe_first :: [a] -> Maybe a
+maybe_first xs = case xs of
+ [] -> Nothing
+ (y:_) -> Just y
+
+
+update_list :: (a -> Bool) -> (a -> a) -> [a] -> [a]
+update_list p f xs = do
+ x <- xs
+ let y = if p x then f x else x
+ return y
+
+puts :: String -> IO ()
+puts = putStrLn
+
+
+exit_success :: IO ()
+exit_success = exitWith ExitSuccess
+
+decode_json :: (Data a) => String -> Either String a
+decode_json s =
+ case runGetJSON readJSValue s of
+ Left msg -> Left msg
+ Right j ->
+ case fromJSON j of
+ Error msg -> Left msg
+ Ok x -> Right x
+
+fork :: IO a -> IO ()
+fork io = void - forkIO - void io
+
+
+insert_unique :: (Eq a) => a -> [a] -> [a]
+insert_unique x xs = x : xs.reject (is x)
+
+squeeze :: (Monad m) => m (m a) -> m a
+squeeze = Monad.join
+
+end :: (Monad m) => m ()
+end = return ()
+
+
+mapT :: (HasGetter g, HasSetter g) => (a -> a) -> [g a] -> IO [g a]
+mapT f xs = xs.mapM (\o -> do
+ o $~ f
+ return o
+ )
+
+filterT :: (HasGetter g) => (a -> Bool) -> [g a] -> IO [g a]
+filterT f xs = xs.mapM (\o -> do
+ object <- get o
+ if f object
+ then return - Just o
+ else return - Nothing
+ )
+ .fmap catMaybes
+
+findT :: (HasGetter g) => (a -> Bool) -> [g a] -> IO (Maybe (g a))
+findT f xs = filterT f xs ^ listToMaybe
+
+find_or_fail_with_message_T :: (HasGetter g) => String -> (a -> Bool) -> [g a] -> IO (g a)
+find_or_fail_with_message_T msg f xs = do
+ r <- findT f xs
+ case r of
+ Nothing -> error msg
+ Just _r -> return _r
+
+
+
+now_in_micro_seconds :: IO Integer
+now_in_micro_seconds =
+ now ^ (utcTimeToPOSIXSeconds > (* 1000000) > floor)
+
+now_in_milli_seconds :: IO Integer
+now_in_milli_seconds =
+ now ^ (utcTimeToPOSIXSeconds > (* 1000) > floor)
+
+return_after :: (RealFrac a) => a -> IO ExitCode -> IO ExitCode
+return_after secs io = do
+ exit_code_ref <- newTVarIO Nothing
+
+ thread_id <- forkIO - do
+ exit_code <- io
+ atom - writeTVar exit_code_ref - Just exit_code
+
+ bomb_time <- now ^ t2f ^ (P.+ secs)
+
+ let { wait_loop = do
+ exit_code <- atom - readTVar exit_code_ref
+
+ case exit_code of
+ Just code -> return code
+ Nothing -> do
+ time_stamp <- now ^ t2f
+
+ if time_stamp >= bomb_time
+ then do
+ -- killThread thread_id
+ return - ExitFailure (-1)
+ else do
+ -- putStrLn "sleeping ..."
+ sleep 0.1
+ wait_loop
+ }
+
+ wait_loop
+
diff --git a/src/Rika/Data/Record/Label.hs b/src/Rika/Data/Record/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Rika/Data/Record/Label.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, TemplateHaskell #-}
+module Rika.Data.Record.Label
+ (
+ -- * Getter, setter and modifier types.
+ Getter
+ , Setter
+ , Modifier
+
+ -- * Label type.
+ , Point
+ , (:->) (Label)
+ , label
+ , get, set, mod
+
+ , fmapL
+
+ -- * Bidirectional functor.
+ , (:<->:) (..)
+ , (<->)
+ , Iso (..)
+ , lmap
+ , for
+
+ -- * State monadic label operations.
+
+ , getM, setM, modM, (=:)
+
+ -- * Derive labels using Template Haskell.
+ , module Rika.Data.Record.Label.TH
+ )
+where
+
+import Prelude hiding ((.), id, mod)
+import Control.Applicative
+import Control.Category
+import Control.Monad.State hiding (get)
+import Rika.Data.Record.Label.TH
+
+type Getter f o = f -> o
+type Setter f i = i -> f -> f
+type Modifier f i o = (o -> i) -> f -> f
+
+data Point f i o = Point
+ { _get :: Getter f o
+ , _set :: Setter f i
+ }
+
+_mod :: Point f i o -> (o -> i) -> f -> f
+_mod l f a = _set l (f (_get l a)) a
+
+newtype (f :-> a) = Label { unLabel :: Point f a a }
+
+-- Create a label out of a getter and setter.
+
+label :: Getter f a -> Setter f a -> f :-> a
+label g s = Label (Point g s)
+
+-- | Get the getter function from a label.
+
+get :: (f :-> a) -> f -> a
+get = _get . unLabel
+
+-- | Get the setter function from a label.
+
+set :: (f :-> a) -> a -> f -> f
+set = _set . unLabel
+
+-- | Get the modifier function from a label.
+
+mod :: (f :-> a) -> (a -> a) -> f -> f
+mod = _mod . unLabel
+
+instance Category (:->) where
+ id = Label (Point id const)
+ (Label a) . (Label b) = Label (Point (_get a . _get b) (_mod b . _set a))
+
+instance Functor (Point f i) where
+ fmap f x = Point (f . _get x) (_set x)
+
+instance Applicative (Point f i) where
+ pure a = Point (const a) (const id)
+ a <*> b = Point (_get a <*> _get b) (\r -> _set b r . _set a r)
+
+fmapL :: Applicative f => (a :-> b) -> f a :-> f b
+fmapL l = label (fmap (get l)) (\x f -> set l <$> x <*> f)
+
+-- | This isomorphism type class is like a `Functor' but works in two directions.
+
+class Iso f where
+ iso :: a :<->: b -> f a -> f b
+ iso (Lens a b) = osi (b <-> a)
+ osi :: a :<->: b -> f b -> f a
+ osi (Lens a b) = iso (b <-> a)
+
+-- | The lens datatype, a function that works in two directions. To bad there
+-- is no convenient way to do application for this.
+
+data a :<->: b = Lens { fw :: a -> b, bw :: b -> a }
+
+-- | Constructor for lenses.
+
+infixr 7 <->
+(<->) :: (a -> b) -> (b -> a) -> a :<->: b
+a <-> b = Lens a b
+
+instance Category (:<->:) where
+ id = Lens id id
+ (Lens a b) . (Lens c d) = Lens (a . c) (d . b)
+
+instance Iso ((:->) i) where
+ iso l (Label a) = Label (Point (fw l . _get a) (_set a . bw l))
+
+instance Iso ((:<->:) i) where
+ iso = (.)
+
+lmap :: Functor f => (a :<->: b) -> f a :<->: f b
+lmap l = let (Lens a b) = l in fmap a <-> fmap b
+
+dimap :: (o' -> o) -> (i -> i') -> Point f i' o' -> Point f i o
+dimap f g l = Point (f . _get l) (_set l . g)
+
+-- | Combine a partial destructor with a label into something easily used in
+-- the applicative instance for the hidden `Point' datatype. Internally uses
+-- the covariant in getter, contravariant in setter bi-functioral-map function.
+-- (Please refer to the example because this function is just not explainable
+-- on its own.)
+
+for :: (i -> o) -> (f :-> o) -> Point f i o
+for a b = dimap id a (unLabel b)
+
+-- | Get a value out of state pointed to by the specified label.
+
+getM :: MonadState s m => s :-> b -> m b
+getM = gets . get
+
+-- | Set a value somewhere in state pointed to by the specified label.
+
+setM :: MonadState s m => s :-> b -> b -> m ()
+setM l = modify . set l
+
+-- | Alias for `setM' that reads like an assignment.
+
+infixr 7 =:
+(=:) :: MonadState s m => s :-> b -> b -> m ()
+(=:) = setM
+
+-- | Modify a value with a function somewhere in state pointed to by the
+-- specified label.
+
+modM :: MonadState s m => s :-> b -> (b -> b) -> m ()
+modM l = modify . mod l
+
diff --git a/src/Rika/Data/Record/Label/TH.hs b/src/Rika/Data/Record/Label/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Rika/Data/Record/Label/TH.hs
@@ -0,0 +1,38 @@
+module Rika.Data.Record.Label.TH (mkLabels) where
+
+import Control.Monad
+import Data.Char
+import Language.Haskell.TH.Syntax
+
+-- | Derive labels for all the record selector in a datatype.
+mkLabels :: [Name] -> Q [Dec]
+mkLabels = liftM concat . mapM mkLabels1
+
+mkLabels1 :: Name -> Q [Dec]
+mkLabels1 n = do
+ i <- reify n
+ let -- only process data and newtype declarations
+ cs' = case i of
+ TyConI (DataD _ _ _ cs _) -> cs
+ TyConI (NewtypeD _ _ _ c _) -> [c]
+ _ -> []
+ -- we're only interested in labels of record constructors
+ ls' = [ l | RecC _ ls <- cs', l <- ls ]
+ return (map mkLabel1 ls')
+
+mkLabel1 :: VarStrictType -> Dec
+mkLabel1 (name, _, _) =
+ -- Generate a name for the label:
+ -- If the original selector starts with an _, remove it and make the next
+ -- character lowercase. Otherwise, add 'l', and make the next character
+ -- uppercase.
+ let n = mkName $ case nameBase name of
+ ('_' : c : rest) -> toLower c : rest
+ (f : rest) -> '_' : '_' : f : rest -- XXX. prefix with __
+ _ -> ""
+ in FunD n [Clause [] (NormalB (
+ AppE (AppE (VarE (mkName "label")) (VarE name)) -- getter
+ (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter
+ (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))
+ )) []]
+
diff --git a/src/Rika/Type/Default.hs b/src/Rika/Type/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Rika/Type/Default.hs
@@ -0,0 +1,50 @@
+module Rika.Type.Default where
+
+import qualified Data.ByteString.Char8 as B
+
+import Control.Concurrent.STM
+
+-- BEGIN
+-- copy from data.default
+
+import Data.Ratio
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+import Debug.Trace
+
+-- | A class for types with a default value.
+class Default a where
+ -- | The default value for this type.
+ def :: a
+
+instance Default () where def = ()
+
+instance Default (S.Set v) where def = S.empty
+instance Default (M.Map k v) where def = M.empty
+
+instance Default Int where def = 0
+instance Default Integer where def = 0
+instance Default Float where def = 0
+instance Default Double where def = 0
+instance (Integral a) => Default (Ratio a) where def = 0
+
+instance Default (Maybe a) where def = Nothing
+instance Default [a] where def = []
+
+instance (Default r) => Default (e -> r) where def _ = def
+instance (Default a) => Default (IO a) where def = return def
+
+instance (Default a, Default b) => Default (a, b) where
+ def = (def, def)
+
+-- END
+
+
+instance Default (TVar a) where
+ def = error "undefined tvar used in default instance"
+
+instance Default B.ByteString where
+ def = B.empty
+
+