packages feed

source-code-server (empty) → 2010.9.1

raw patch · 18 files changed

+1606/−0 lines, 18 filesdep +HDBCdep +HDBC-sqlite3dep +StateVarsetup-changed

Dependencies added: HDBC, HDBC-sqlite3, StateVar, base, bytestring, containers, curl, data-default, directory, filepath, hack, hack-contrib, hack-handler-happstack, haskell98, json, loli, mps, mtl, process, safe, stm, template-haskell, time, unix

Files

+ LICENSE view
@@ -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.
+ Nemesis view
@@ -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"
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ readme.md view
@@ -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+==================++<br/>+<br/>++![source-code](http://github.com/nfjinjing/source-code-server/raw/master/source-code.jpg)
+ source-code-server.cabal view
@@ -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 <nfjinjing@gmail.com>+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+
+ src/CodeMushu/Constant.hs view
@@ -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"+  }
+ src/CodeMushu/DSL.hs view
@@ -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+
+ src/CodeMushu/Driver/Server.hs view
@@ -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++
+ src/CodeMushu/Env.hs view
@@ -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
+ src/CodeMushu/Project.hs view
@@ -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"
+ src/CodeMushu/Repo.hs view
@@ -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(?, ?, ?, ?, ?, ?)++|]
+ src/CodeMushu/Server.hs view
@@ -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
+ src/CodeMushu/Thread.hs view
@@ -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
+ src/CodeMushu/Type.hs view
@@ -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+  ]
+ src/MPS/Lab1.hs view
@@ -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+
+ src/Rika/Data/Record/Label.hs view
@@ -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+
+ src/Rika/Data/Record/Label/TH.hs view
@@ -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"))]))+                                   )) []]+
+ src/Rika/Type/Default.hs view
@@ -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++