├── .gitignore ├── CHANGES.md ├── README.md ├── doc ├── haskus.css └── reports │ ├── 2d-region-intersect │ ├── 2d-region-intersect.tex │ ├── Makefile │ ├── grid.sty │ └── rvdtx.sty │ └── data-management │ ├── Makefile │ ├── data-management.tex │ ├── grid.sty │ └── rvdtx.sty ├── haskus-system-build ├── LICENSE ├── README.md ├── haskus-system-build.cabal └── src │ └── apps │ └── Haskus │ └── Apps │ └── System │ └── Build │ ├── CmdLine.hs │ ├── Config.hs │ ├── Disk.hs │ ├── Download.hs │ ├── GMP.hs │ ├── ISO.hs │ ├── Linux.hs │ ├── Main.hs │ ├── QEMU.hs │ ├── Ramdisk.hs │ ├── Stack.hs │ ├── Syslinux.hs │ └── Utils.hs ├── haskus-system-tools ├── README.rst ├── haskus-system-tools.cabal ├── package.yaml └── src │ ├── disassembler │ └── Main.hs │ ├── elf │ ├── CmdLine.hs │ ├── Main.hs │ └── style.css │ ├── gunzip │ └── Main.hs │ ├── huffman │ └── Main.hs │ ├── keys │ └── Main.hs │ ├── system-info │ ├── CmdLine.hs │ ├── Main.hs │ └── style.css │ └── udev │ └── Main.hs ├── haskus-system ├── LICENSE ├── haskus-system.cabal └── src │ ├── lib │ └── Haskus │ │ ├── Apps │ │ ├── CPIO.hs │ │ └── Disassembler.hs │ │ ├── Arch │ │ ├── Common │ │ │ ├── Immediate.hs │ │ │ ├── Memory.hs │ │ │ ├── Register.hs │ │ │ └── Solver.hs │ │ └── X86_64 │ │ │ ├── Cpuid.hs │ │ │ ├── Disassembler.hs │ │ │ ├── ISA │ │ │ ├── Decoder.hs │ │ │ ├── Encoding.hs │ │ │ ├── Immediate.hs │ │ │ ├── Insn.hs │ │ │ ├── Insns.hs │ │ │ ├── Memory.hs │ │ │ ├── MicroArch.hs │ │ │ ├── Mode.hs │ │ │ ├── OpcodeMaps.hs │ │ │ ├── Operand.hs │ │ │ ├── Register.hs │ │ │ ├── Size.hs │ │ │ └── Solver.hs │ │ │ ├── Linux │ │ │ ├── Syscall.hs │ │ │ ├── SyscallTable.hs │ │ │ ├── Syscalls.hs │ │ │ └── syscall.s │ │ │ └── cpuid.c │ │ ├── Format │ │ ├── CPIO.hs │ │ ├── Compression │ │ │ ├── Algorithms │ │ │ │ ├── Deflate.hs │ │ │ │ ├── Huffman.hs │ │ │ │ └── LZ77.hs │ │ │ └── GZip.hs │ │ ├── Dwarf.hs │ │ ├── Elf.hs │ │ ├── Elf │ │ │ ├── Dynamic.hs │ │ │ ├── GHC.hs │ │ │ ├── Header.hs │ │ │ ├── Intel.hs │ │ │ ├── Move.hs │ │ │ ├── Note.hs │ │ │ ├── PreHeader.hs │ │ │ ├── Relocation.hs │ │ │ ├── RelocationType.hs │ │ │ ├── Section.hs │ │ │ ├── Segment.hs │ │ │ ├── Symbol.hs │ │ │ └── Version.hs │ │ ├── FileSystem │ │ │ └── ISO9660.hs │ │ ├── String.hs │ │ └── Text.hs │ │ ├── System.hs │ │ └── System │ │ ├── Devices.hs │ │ ├── Event.hs │ │ ├── EventLoop.hs │ │ ├── FileSystem.hs │ │ ├── Graphics.hs │ │ ├── Graphics │ │ ├── Colour.hs │ │ ├── Config.hs │ │ ├── Diagrams.hs │ │ ├── Drawing.hs │ │ └── Scene.hs │ │ ├── Input.hs │ │ ├── Linux │ │ ├── Devices.hs │ │ ├── Error.hs │ │ ├── ErrorCode.hs │ │ ├── EventPoll.hs │ │ ├── FileSystem.hs │ │ ├── FileSystem │ │ │ ├── Directory.hs │ │ │ ├── Mount.hs │ │ │ ├── Notification.hs │ │ │ ├── ReadWrite.hs │ │ │ └── SymLink.hs │ │ ├── Futex.hs │ │ ├── Graphics │ │ │ ├── AtomicConfig.hs │ │ │ ├── Capability.hs │ │ │ ├── Entities.hs │ │ │ ├── Event.hs │ │ │ ├── FrameSource.hs │ │ │ ├── Helper.hs │ │ │ ├── HostBuffer.hs │ │ │ ├── Mode.hs │ │ │ ├── Object.hs │ │ │ ├── PixelFormat.hs │ │ │ ├── Property.hs │ │ │ └── State.hs │ │ ├── Handle.hs │ │ ├── Info.hs │ │ ├── Input.hs │ │ ├── Internals │ │ │ ├── Arg.hs │ │ │ ├── Error.hs │ │ │ ├── Fcntl.hs │ │ │ ├── FileSystem.hs │ │ │ ├── Graphics.hs │ │ │ ├── Handle.hs │ │ │ ├── IfLink.hs │ │ │ ├── Input.hs │ │ │ ├── Ioctl.hs │ │ │ ├── Netlink.hs │ │ │ ├── NetlinkRoute.hs │ │ │ ├── Reboot.hs │ │ │ ├── Sound.hs │ │ │ ├── Tables.hs │ │ │ └── Terminal.hs │ │ ├── Ioctl.hs │ │ ├── KernelEvent.hs │ │ ├── Memory.hs │ │ ├── Modules.hs │ │ ├── Network.hs │ │ ├── Network │ │ │ └── SendReceive.hs │ │ ├── Pipe.hs │ │ ├── Power.hs │ │ ├── Process.hs │ │ ├── Process │ │ │ ├── Auxiliary.hs │ │ │ ├── ControlGroup.hs │ │ │ └── MemoryMap.hs │ │ ├── Signal.hs │ │ ├── Sound │ │ │ └── Pcm.hs │ │ ├── Syscalls.hs │ │ ├── Terminal.hs │ │ ├── Time.hs │ │ ├── Topology.hs │ │ └── Trace.hs │ │ ├── Network.hs │ │ ├── PCI.hs │ │ ├── PCI │ │ ├── MakeTable.hs │ │ ├── Types.hs │ │ └── pci.ids │ │ ├── Posix │ │ └── Malloc.hs │ │ ├── Power.hs │ │ ├── Process.hs │ │ ├── Process │ │ └── MemoryMap.hs │ │ ├── Sys.hs │ │ ├── System.hs │ │ └── Terminal.hs │ └── tests │ ├── Haskus │ ├── Tests.hs │ └── Tests │ │ ├── Arch.hs │ │ ├── Arch │ │ ├── Linux.hs │ │ └── Linux │ │ │ ├── ErrorCode.hs │ │ │ └── Input.hs │ │ ├── Common.hs │ │ ├── Format.hs │ │ ├── System.hs │ │ └── System │ │ └── Devices.hs │ └── Main.hs ├── manage.sh ├── scripts ├── ContFlow.hs ├── Unums.hs └── json.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.swp 3 | *.out 4 | *.log 5 | *.aux 6 | *.toc 7 | *.pdf 8 | *.swo 9 | *.swn 10 | *.o 11 | *.hi 12 | cabal.sandbox.config 13 | .cabal-sandbox 14 | .stack-work 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskus system 2 | 3 | Haskus system is a framework written in Haskell and designed for system 4 | programming. Fundamentally it is an experiment into providing an integrated 5 | interface leveraging Haskell features (type-safety, STM, etc.) for the whole 6 | system: input, display, sound, network, etc. 7 | 8 | Website: http://www.haskus.org/system 9 | 10 | Documentation: https://docs.haskus.org/system.html 11 | 12 | # Building systems 13 | 14 | The [haskus-system-build](https://github.com/haskus/haskus-system-build.git) 15 | tool (in the package of the same name) is the preferred way to build systems. 16 | 17 | You can install it from source with: 18 | 19 | ```bash 20 | $ git clone https://github.com/haskus/haskus-system.git 21 | $ cd haskus-system 22 | $ stack install haskus-system-build 23 | ``` 24 | 25 | It will install the program into ~/.local/bin. Be sure to add this path to your 26 | $PATH environment variable. 27 | 28 | Then in a **new directory** do: 29 | ```bash 30 | $ haskus-system-build init # download default system template 31 | $ haskus-system-build test # download, build and test system in QEMU 32 | ``` 33 | 34 | You may have to install missing programs (cpio, lzip, qemu, make, gcc, binutils, 35 | gzip, etc.) for these commands to succeed. See the 36 | [documentation](https://docs.haskus.org/system/building/automatic_building.html#building-and-testing). 37 | 38 | 39 | # Hacking on haskus-system 40 | 41 | Use ``stack`` commands to build the ``haskus-system`` package: 42 | 43 | ```bash 44 | $ stack build # build 45 | $ stack test # run tests 46 | $ stack bench # run benchmarks 47 | ``` 48 | -------------------------------------------------------------------------------- /doc/reports/2d-region-intersect/Makefile: -------------------------------------------------------------------------------- 1 | ## 2 | ## Makefile 3 | ## 4 | ## This file is in public domain. 5 | ## River Valley Technologies 6 | ## http://www.river-valley.com 7 | ## 8 | ## 9 | 10 | file=2d-region-intersect 11 | 12 | 13 | all: pdf out 14 | make pdf 15 | 16 | out: 17 | if [ -f $(file).out ] ; then cp $(file).out tmp.out; fi ; 18 | sed 's/BOOKMARK/dtxmark/g;' tmp.out > x.out; mv x.out tmp.out ; 19 | 20 | pdf: 21 | pdflatex $(file).tex 22 | 23 | index: 24 | makeindex -s gind.ist -o $(file).ind $(file).idx 25 | 26 | changes: 27 | makeindex -s gglo.ist -o $(file).gls $(file).glo 28 | 29 | xview: 30 | # xpdf -z 200 $(file).pdf &>/dev/null 31 | open -a 'Skim.app' $(file).pdf 32 | 33 | view: 34 | open -a 'Adobe Reader.app' $(file).pdf 35 | 36 | ins: 37 | latex $(file).ins 38 | 39 | diff: 40 | diff $(file).sty ../$(file).sty |less 41 | 42 | copy: 43 | cp $(file).sty ../ 44 | 45 | -------------------------------------------------------------------------------- /doc/reports/data-management/Makefile: -------------------------------------------------------------------------------- 1 | ## 2 | ## Makefile 3 | ## 4 | ## This file is in public domain. 5 | ## River Valley Technologies 6 | ## http://www.river-valley.com 7 | ## 8 | ## 9 | 10 | file=data-management 11 | 12 | 13 | all: pdf out 14 | make pdf 15 | 16 | out: 17 | if [ -f $(file).out ] ; then cp $(file).out tmp.out; fi ; 18 | sed 's/BOOKMARK/dtxmark/g;' tmp.out > x.out; mv x.out tmp.out ; 19 | 20 | pdf: 21 | pdflatex $(file).tex 22 | 23 | index: 24 | makeindex -s gind.ist -o $(file).ind $(file).idx 25 | 26 | changes: 27 | makeindex -s gglo.ist -o $(file).gls $(file).glo 28 | 29 | xview: 30 | # xpdf -z 200 $(file).pdf &>/dev/null 31 | open -a 'Skim.app' $(file).pdf 32 | 33 | view: 34 | open -a 'Adobe Reader.app' $(file).pdf 35 | 36 | ins: 37 | latex $(file).ins 38 | 39 | diff: 40 | diff $(file).sty ../$(file).sty |less 41 | 42 | copy: 43 | cp $(file).sty ../ 44 | 45 | -------------------------------------------------------------------------------- /haskus-system-build/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2017, Haskus organization 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | * Neither the name of Sylvain Henry nor the names of other contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, 22 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 23 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 25 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 26 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 27 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /haskus-system-build/README.md: -------------------------------------------------------------------------------- 1 | # haskus-system-build tool 2 | 3 | This package contains the ``haskus-system-build`` tool. 4 | 5 | Documentation: https://docs.haskus.org/system/building/automatic_building.html 6 | -------------------------------------------------------------------------------- /haskus-system-build/haskus-system-build.cabal: -------------------------------------------------------------------------------- 1 | name: haskus-system-build 2 | version: 1.1 3 | synopsis: Haskus system build tool 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Sylvain Henry 7 | maintainer: sylvain@haskus.fr 8 | homepage: http://www.haskus.org/system 9 | copyright: Sylvain Henry 2018 10 | category: System 11 | build-type: Simple 12 | cabal-version: 1.20 13 | 14 | description: 15 | Build tool to use with haskus-system. 16 | 17 | source-repository head 18 | type: git 19 | location: git://github.com/haskus/haskus-system-build.git 20 | 21 | executable haskus-system-build 22 | main-is: Haskus/Apps/System/Build/Main.hs 23 | hs-source-dirs: src/apps 24 | other-modules: 25 | Haskus.Apps.System.Build.Config 26 | Haskus.Apps.System.Build.Linux 27 | Haskus.Apps.System.Build.Ramdisk 28 | Haskus.Apps.System.Build.Syslinux 29 | Haskus.Apps.System.Build.Stack 30 | Haskus.Apps.System.Build.CmdLine 31 | Haskus.Apps.System.Build.Utils 32 | Haskus.Apps.System.Build.GMP 33 | Haskus.Apps.System.Build.QEMU 34 | Haskus.Apps.System.Build.ISO 35 | Haskus.Apps.System.Build.Disk 36 | Haskus.Apps.System.Build.Download 37 | Paths_haskus_system_build 38 | build-depends: 39 | base >= 4.9 && < 5.0 40 | , process >= 1.4 41 | , yaml >= 0.8 42 | , text >= 1.2 43 | , haskus-utils >= 0.7 44 | , optparse-simple >= 0.0 45 | , optparse-applicative >= 0.13 46 | , temporary >= 1.2 47 | , directory >= 1.2 48 | , filepath >= 1.4 49 | , hashable >= 1.2 50 | , http-conduit 51 | , conduit 52 | 53 | default-language: Haskell2010 54 | ghc-options: -Wall -threaded 55 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/CmdLine.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Apps.System.Build.CmdLine 2 | ( InitOptions(..) 3 | , BuildOptions (..) 4 | , TestOptions (..) 5 | , MakeDiskOptions (..) 6 | , MakeDeviceOptions (..) 7 | , initOptions 8 | , buildOptions 9 | , testOptions 10 | , makeDiskOptions 11 | , makeDeviceOptions 12 | ) 13 | where 14 | 15 | import Options.Applicative 16 | 17 | data InitOptions = InitOptions 18 | { initOptTemplate :: String 19 | } 20 | 21 | initOptions :: Parser InitOptions 22 | initOptions = 23 | InitOptions 24 | <$> strOption 25 | ( long "template" 26 | <> short 't' 27 | <> metavar "TEMPLATE" 28 | <> value "default" 29 | <> help "Template to use" 30 | ) 31 | 32 | data TestOptions = TestOptions 33 | { testOptInit :: String 34 | } 35 | 36 | testOptions :: Parser TestOptions 37 | testOptions = 38 | TestOptions 39 | <$> strOption 40 | ( long "init" 41 | <> metavar "INIT-PROGRAM" 42 | <> value "" 43 | <> help "Init program to use" 44 | ) 45 | 46 | data BuildOptions = BuildOptions 47 | { buildOptInit :: String 48 | } 49 | 50 | buildOptions :: Parser BuildOptions 51 | buildOptions = 52 | BuildOptions 53 | <$> strOption 54 | ( long "init" 55 | <> metavar "INIT-PROGRAM" 56 | <> value "" 57 | <> help "Init program to use" 58 | ) 59 | 60 | data MakeDiskOptions = MakeDiskOptions 61 | { diskOptPath :: String 62 | } 63 | 64 | makeDiskOptions :: Parser MakeDiskOptions 65 | makeDiskOptions = 66 | MakeDiskOptions 67 | <$> strOption 68 | ( long "output" 69 | <> short 'o' 70 | <> metavar "OUTPUT-DIRECTORY" 71 | <> help "Output disk directory" 72 | ) 73 | 74 | data MakeDeviceOptions = MakeDeviceOptions 75 | { deviceOptPath :: String 76 | } 77 | 78 | makeDeviceOptions :: Parser MakeDeviceOptions 79 | makeDeviceOptions = 80 | MakeDeviceOptions 81 | <$> strOption 82 | ( long "device" 83 | <> short 'd' 84 | <> metavar "DEVICE" 85 | <> help "Device path" 86 | ) 87 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/Disk.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Apps.System.Build.Disk 2 | ( withDisk 3 | , makeDisk 4 | , makeDevice 5 | ) 6 | where 7 | 8 | import Haskus.Apps.System.Build.Config 9 | import Haskus.Apps.System.Build.Utils 10 | import Haskus.Apps.System.Build.Ramdisk 11 | import Haskus.Apps.System.Build.Linux 12 | import Haskus.Apps.System.Build.Syslinux 13 | 14 | import System.IO.Temp 15 | import System.FilePath 16 | import System.Directory 17 | import qualified Data.Text as Text 18 | import qualified Data.Text.IO as Text 19 | import Control.Exception (finally) 20 | 21 | 22 | -- | Create a temp directory containing the system and call the callback 23 | withDisk :: SystemConfig -> (FilePath -> IO a) -> IO a 24 | withDisk config callback = do 25 | 26 | withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do 27 | -- create the disk 28 | makeDisk config tmpfp 29 | 30 | -- call the callback 31 | callback tmpfp 32 | 33 | -- | Mount a device and install a system in it 34 | makeDevice :: SystemConfig -> FilePath -> IO () 35 | makeDevice config dev = do 36 | -- TODO: allow the selection of another boot partition 37 | -- TODO: ensure that the partition is bootable 38 | -- TODO: check filesystem 39 | let dev' = dev ++ "1" 40 | showStep $ "Installing in partition " ++ dev' ++"..." 41 | withDisk config $ \disk -> do 42 | withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do 43 | shellWaitErr ("sudo mount "++dev'++" "++tmpfp++" -o rw") 44 | $ failWith "Unable to mount device" 45 | (do 46 | shellWaitErr ("sudo cp -r " ++ disk ++"/* "++tmpfp) 47 | (failWith "Cannot copy files on the mounted device") 48 | syslinuxInstall (syslinuxConfig config) dev tmpfp 49 | ) `finally` 50 | shellWaitErr ("sudo umount "++tmpfp) 51 | (failWith "Unable to umount device") 52 | 53 | 54 | 55 | -- | Create a disk in the given folder 56 | makeDisk :: SystemConfig -> FilePath -> IO () 57 | makeDisk config tmpfp = do 58 | showStep "Creating system disk..." 59 | 60 | -- create directories 61 | let syslinuxfp = tmpfp "boot" "syslinux" 62 | createDirectoryIfMissing True syslinuxfp 63 | 64 | -- copy Syslinux 65 | syslinuxPath <- syslinuxMain (syslinuxConfig config) 66 | -- copy *.c32 files 67 | copyDirectory (syslinuxPath "bios") syslinuxfp True 68 | (return . (== ".c32") . takeExtension) 69 | -- copy isolinux.bin 70 | copyFile (syslinuxPath "bios" "core" "isolinux.bin") 71 | (syslinuxfp "isolinux.bin") 72 | 73 | -- copy linux 74 | srcLinuxFile <- linuxKernelFile (linuxConfig config) 75 | let 76 | kernelPath = "boot" takeFileName srcLinuxFile 77 | linuxFile = tmpfp kernelPath 78 | copyFile srcLinuxFile linuxFile 79 | 80 | -- copy the ramdisk 81 | srcRamdiskFile <- ramdiskGetPath (ramdiskConfig config) 82 | let 83 | ramdiskPath = "boot" takeFileName srcRamdiskFile 84 | ramdiskFile = tmpfp ramdiskPath 85 | copyFile srcRamdiskFile ramdiskFile 86 | 87 | -- configure Syslinux 88 | let 89 | cfg = syslinuxConfigFile config (Text.pack kernelPath) 90 | (Text.pack ramdiskPath) 91 | cfgPath = syslinuxfp "syslinux.cfg" 92 | Text.writeFile cfgPath cfg 93 | 94 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/Download.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Haskus.Apps.System.Build.Download 4 | ( download 5 | ) 6 | where 7 | 8 | import Network.HTTP.Simple 9 | import Conduit 10 | 11 | download :: 12 | ( MonadUnliftIO m 13 | , MonadThrow m 14 | ) => String -> FilePath -> m () 15 | download url filepath = do 16 | req <- parseRequest url 17 | runResourceT $ httpSink req $ const (sinkFile filepath) 18 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/GMP.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Apps.System.Build.GMP 2 | ( gmpMain 3 | ) 4 | where 5 | 6 | import Haskus.Apps.System.Build.Utils 7 | import Haskus.Utils.Flow 8 | 9 | import System.IO.Temp 10 | import System.Directory 11 | import System.FilePath 12 | 13 | gmpMain :: IO () 14 | gmpMain = do 15 | 16 | appDir <- getAppDir 17 | let 18 | usrDir = appDir "usr" 19 | gmpVer = "6.1.2" 20 | libFile = usrDir "lib" "libgmp.a" 21 | 22 | 23 | createDirectoryIfMissing True usrDir 24 | 25 | unlessM (doesFileExist libFile) $ do 26 | 27 | withSystemTempDirectory "haskus-system-build" $ \fp -> do 28 | 29 | showStep $ "Downloading libgmp " ++ gmpVer ++"..." 30 | let fp2 = fp "gmp.tar.lz" 31 | download 32 | ("https://gmplib.org/download/gmp/gmp-"++gmpVer++".tar.lz") 33 | fp2 34 | 35 | showStep "Unpacking libgmp..." 36 | untar fp2 fp 37 | 38 | let fp3 = fp ("gmp-"++gmpVer) 39 | 40 | showStep "Configuring libgmp..." 41 | shellInErr fp3 ("./configure --prefix=" ++ usrDir) 42 | $ failWith "Cannot configure libgmp" 43 | 44 | showStep "Building libgmp..." 45 | shellInErr fp3 "make -j8" 46 | $ failWith "Cannot build libgmp" 47 | 48 | showStep "Installing libgmp..." 49 | shellInErr fp3 "make install" 50 | $ failWith "Cannot install libgmp" 51 | 52 | workDir <- getWorkDir 53 | let libDir = workDir "lib" 54 | createDirectoryIfMissing True libDir 55 | 56 | unlessM (doesFileExist (libDir "libgmp.a")) $ do 57 | showStep "Copying libgmp.a into .system-work" 58 | copyFile libFile (libDir "libgmp.a") 59 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/ISO.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Apps.System.Build.ISO 2 | ( isoMake 3 | ) 4 | where 5 | 6 | import Haskus.Apps.System.Build.Config 7 | import Haskus.Apps.System.Build.Utils 8 | import Haskus.Apps.System.Build.Disk 9 | import Haskus.Apps.System.Build.Syslinux 10 | 11 | import System.FilePath 12 | import System.Directory 13 | import qualified Data.Text as Text 14 | import qualified Data.List as List 15 | 16 | 17 | isoMake :: SystemConfig -> IO FilePath 18 | isoMake config = do 19 | 20 | wd <- getWorkDir 21 | let 22 | isoPath = wd "iso" 23 | isoFile = isoPath Text.unpack (ramdiskInit (ramdiskConfig config)) <.> "iso" 24 | 25 | -- get hybrid MBR file path 26 | syslinuxpath <- syslinuxMain (syslinuxConfig config) 27 | let mbrfile = syslinuxpath "bios" "mbr" "isohdpfx_c.bin" 28 | 29 | createDirectoryIfMissing True isoPath 30 | 31 | withDisk config $ \fp -> do 32 | showStep "Building ISO image..." 33 | shellWaitErr 34 | (mconcat $ List.intersperse " " 35 | [ "xorriso -as mkisofs" 36 | , "-R -J" -- use rock-ridge/joliet extensions 37 | , "-o ", isoFile 38 | , "-c boot/syslinux/boot.cat" -- create boot catalog 39 | , "-b boot/syslinux/isolinux.bin" -- bootable binary file 40 | , "-no-emul-boot" -- don't use legacy floppy emulation 41 | , "-boot-info-table" -- write additional boot info table 42 | -- (required by Sylinux) 43 | , "-boot-load-size 4" 44 | , "-isohybrid-mbr", mbrfile 45 | , fp 46 | ]) 47 | (failWith "Unable to create ISO image") 48 | putStrLn $ "ISO image: " ++ isoFile 49 | return isoFile 50 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/QEMU.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Haskus.Apps.System.Build.QEMU 4 | ( qemuExecRamdisk 5 | , qemuExecISO 6 | , qemuGetProfileConfig 7 | , qemuExec 8 | ) 9 | where 10 | 11 | import Haskus.Apps.System.Build.Config 12 | import Haskus.Apps.System.Build.Utils 13 | import Haskus.Apps.System.Build.Ramdisk 14 | import Haskus.Apps.System.Build.Linux 15 | 16 | import Data.List 17 | import qualified Data.Text as Text 18 | 19 | -- | Execute (ramdisk + kernel) 20 | qemuExecRamdisk :: SystemConfig -> IO () 21 | qemuExecRamdisk config = do 22 | 23 | (args,kargs) <- qemuGetProfileConfig (qemuConfig config) 24 | 25 | kernel <- linuxKernelFile (linuxConfig config) 26 | ramdisk <- ramdiskGetPath (ramdiskConfig config) 27 | let rdinit = Text.unpack (ramdiskInit (ramdiskConfig config)) 28 | 29 | let kerRdArgs = concat $ intersperse " " 30 | [ "-kernel", kernel 31 | , "-initrd", ramdisk 32 | , "-append", ("\"rdinit=/" ++ rdinit ++ " " ++ kargs ++ "\"") 33 | ] 34 | 35 | qemuExec (args ++ " " ++ kerRdArgs) 36 | 37 | -- | Execute ISO 38 | qemuExecISO :: SystemConfig -> FilePath -> IO () 39 | qemuExecISO config isoPath = do 40 | 41 | (args,_) <- qemuGetProfileConfig (qemuConfig config) 42 | 43 | let kerRdArgs = concat $ intersperse " " 44 | [ "-cdrom", isoPath 45 | ] 46 | 47 | qemuExec (args ++ " " ++ kerRdArgs) 48 | 49 | 50 | qemuExec :: String -> IO () 51 | qemuExec args = do 52 | let cmd = "qemu-system-x86_64 " ++ args 53 | 54 | showStep "Launching QEMU..." 55 | shellWaitErr cmd $ failWith "Cannot execute QEMU" 56 | 57 | 58 | qemuGetProfileConfig :: QEMUConfig -> IO (String,String) 59 | qemuGetProfileConfig config = 60 | case qemuProfile config of 61 | "vanilla" -> return ( Text.unpack (qemuOptions config) 62 | , Text.unpack (qemuKernelArgs config) 63 | ) 64 | "default" -> return $ 65 | (concat $ intersperse " " 66 | [ "-enable-kvm" 67 | , "-machine q35" 68 | , "-serial stdio" 69 | , "-vga std" 70 | --, "-show-cursor" 71 | , "-usb" 72 | , "-device usb-ehci,id=ehci" 73 | , "-device usb-tablet,bus=usb-bus.0" 74 | , "-device intel-hda -device hda-duplex" 75 | , Text.unpack (qemuOptions config) 76 | ] 77 | , concat $ intersperse " " 78 | [ "console=ttyS0 atkbd.softraw=0 quiet" 79 | , Text.unpack (qemuKernelArgs config) 80 | ] 81 | ) 82 | p -> failWith $ "Invalid QEMU profile: " ++ Text.unpack p 83 | 84 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/Ramdisk.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Apps.System.Build.Ramdisk 2 | ( ramdiskMain 3 | , ramdiskGetPath 4 | , ramdiskInitPath 5 | ) 6 | where 7 | 8 | import Haskus.Apps.System.Build.Config 9 | import Haskus.Apps.System.Build.Utils 10 | import Haskus.Apps.System.Build.Stack 11 | 12 | import System.IO.Temp 13 | import System.FilePath 14 | import System.Directory 15 | import qualified Data.Text as Text 16 | import Data.Text (Text) 17 | 18 | ramdiskMain :: RamdiskConfig -> IO () 19 | ramdiskMain config = do 20 | rd <- ramdiskGetPath config 21 | let 22 | rdinit = Text.unpack (ramdiskInitPath config) 23 | 24 | binfp <- stackGetBinPath rdinit 25 | 26 | withSystemTempDirectory "haskus-system-build" $ \tmpfp -> do 27 | showStep "Building ramdisk..." 28 | let rdfile = tmpfp rdinit 29 | 30 | -- create directories 31 | createDirectoryIfMissing True (dropFileName rdfile) 32 | 33 | -- copy ramdisk files 34 | copyFile binfp (tmpfp rdinit) 35 | 36 | -- create ramdisk 37 | -- TODO: use our own `cpio` and `gzip` 38 | shellInErr tmpfp 39 | ("(find . | cpio -o -H newc | gzip) > " ++ rd) 40 | $ failWith "Cannot build ramdisk" 41 | 42 | 43 | -- | Get ramdisk 44 | ramdiskGetPath :: RamdiskConfig -> IO FilePath 45 | ramdiskGetPath config = do 46 | workDir <- getWorkDir 47 | let rdDir = workDir "ramdisk" 48 | createDirectoryIfMissing True rdDir 49 | return (rdDir Text.unpack (ramdiskInit config) <.> "img") 50 | 51 | -- | Path of the init program in the ramdisk 52 | -- TODO: add support for custom path 53 | ramdiskInitPath :: RamdiskConfig -> Text 54 | ramdiskInitPath config = 55 | ramdiskInit config 56 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Haskus.Apps.System.Build.Stack 4 | ( stackGetBinPath 5 | , stackGetResolver 6 | , stackGetGHCVersion 7 | , stackBuild 8 | ) 9 | where 10 | 11 | import System.Process 12 | import System.FilePath 13 | import Data.List 14 | 15 | import Haskus.Apps.System.Build.Utils 16 | import Haskus.Utils.Flow 17 | 18 | -- | Get GHC version (using stack exec) 19 | stackGetGHCVersion :: IO String 20 | stackGetGHCVersion = 21 | -- FIXME 22 | last . words <$> readProcess "stack" ["exec", "--", "ghc", "--version"] "" 23 | 24 | -- | Get stack resolver 25 | stackGetResolver :: IO String 26 | stackGetResolver = 27 | -- FIXME 28 | last . words . head . filter ("resolver:" `isPrefixOf`) . lines <$> readFile "stack.yaml" 29 | 30 | stackGetBinPath :: FilePath -> IO FilePath 31 | stackGetBinPath x = do 32 | p <- readProcess "stack" ["path", "--local-install-root"] "" 33 | return $ init p "bin" x 34 | 35 | 36 | stackBuild :: IO () 37 | stackBuild = do 38 | showStep "Configuring Stack..." 39 | shellWaitErr "stack setup" 40 | <| failWith "Error during `stack setup`" 41 | 42 | showStep "Building with Stack..." 43 | shellWaitErr "stack build" 44 | <| failWith "Error during `stack build`" 45 | 46 | -------------------------------------------------------------------------------- /haskus-system-build/src/apps/Haskus/Apps/System/Build/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Haskus.Apps.System.Build.Utils 4 | ( shellWait 5 | , shellWaitErr 6 | , shellIn 7 | , shellInErr 8 | , untar 9 | , subTitle 10 | , showStep 11 | , failWith 12 | , download 13 | , getAppDir 14 | , getWorkDir 15 | , getDownloadPath 16 | , copyDirectory 17 | ) 18 | where 19 | 20 | import System.Process 21 | import System.Exit 22 | import System.Directory 23 | import System.FilePath 24 | import System.IO.Temp 25 | import Haskus.Utils.Flow 26 | import qualified Haskus.Apps.System.Build.Download as D 27 | 28 | -- | Execute a command 29 | shellWait :: String -> IO ExitCode 30 | shellWait cmd = do 31 | (_,_,_,hdl) <- createProcess (shell cmd) 32 | waitForProcess hdl 33 | 34 | -- | Execute a command, call callback on error 35 | shellWaitErr :: String -> IO () -> IO () 36 | shellWaitErr cmd err = do 37 | shellWait cmd >>= \case 38 | ExitSuccess -> return () 39 | ExitFailure _ -> err 40 | 41 | -- | Execute a command in the given directory 42 | shellIn :: FilePath -> String -> IO ExitCode 43 | shellIn fp cmd = do 44 | (_,_,_,hdl) <- createProcess ((shell cmd) { cwd = Just fp }) 45 | waitForProcess hdl 46 | 47 | 48 | -- | Execute a command in the given directory, call callback on error 49 | shellInErr :: FilePath -> String -> IO () -> IO () 50 | shellInErr fp cmd err = do 51 | shellIn fp cmd >>= \case 52 | ExitSuccess -> return () 53 | ExitFailure _ -> err 54 | 55 | -- | Uncompress an archive 56 | untar :: FilePath -> FilePath -> IO () 57 | untar src tgt = shellInErr tgt ("tar xf " ++ src) $ 58 | failWith "Cannot uncompress archive" 59 | 60 | -- | Add a subline to a text 61 | subTitle :: String -> String 62 | subTitle t = t ++ "\n" ++ replicate (length t) '-' ++ "\n" 63 | 64 | -- | Show progress step 65 | showStep :: String -> IO () 66 | showStep t = putStrLn $ "==> " ++ t 67 | 68 | -- | Print error message 69 | failWith :: String -> IO a 70 | failWith s = die $ "Error: " ++ s 71 | 72 | -- | Download a file 73 | download :: String -> FilePath -> IO () 74 | download url tgt = do 75 | withSystemTempDirectory "haskus-system-build" $ \fp -> do 76 | let fp2 = fp "download.tmp" 77 | D.download url fp2 78 | copyFile fp2 tgt 79 | 80 | -- | Return app directory 81 | getAppDir :: IO FilePath 82 | getAppDir = do 83 | fp <- getAppUserDataDirectory "haskus" 84 | let d = fp "system" "build" 85 | createDirectoryIfMissing True d 86 | return d 87 | 88 | -- | Return work directory 89 | getWorkDir :: IO FilePath 90 | getWorkDir = do 91 | fp <- getCurrentDirectory 92 | let d = fp ".system-work" 93 | createDirectoryIfMissing True d 94 | return d 95 | 96 | -- | Return download path 97 | getDownloadPath :: IO FilePath 98 | getDownloadPath = do 99 | fp <- getAppDir 100 | let d = fp "downloads" 101 | createDirectoryIfMissing True d 102 | return d 103 | 104 | -- | Copy a directory (optionally keeping the structure). Use a predicate to filter 105 | copyDirectory :: FilePath -> FilePath -> Bool -> (FilePath -> IO Bool) -> IO () 106 | copyDirectory src dst flattenDirs filt = go src 107 | where 108 | go currentDir = do 109 | fs <- listDirectory currentDir 110 | forM_ fs $ \f -> do 111 | let fileAbs = currentDir f 112 | isDir <- doesDirectoryExist fileAbs 113 | if isDir 114 | then go (currentDir f) 115 | else do 116 | -- filter 117 | whenM (filt fileAbs) $ do 118 | let 119 | fileRel = makeRelative src fileAbs 120 | dstAbs = if flattenDirs 121 | then dst takeFileName (fileAbs) 122 | else dst fileRel 123 | createDirectoryIfMissing True (dropFileName dstAbs) 124 | copyFile fileAbs dstAbs 125 | 126 | 127 | -------------------------------------------------------------------------------- /haskus-system-tools/README.rst: -------------------------------------------------------------------------------- 1 | ====================================================================== 2 | System tools 3 | ====================================================================== 4 | 5 | ---------------------------------------------------------------------- 6 | haskus-system-info 7 | ---------------------------------------------------------------------- 8 | 9 | Display information about what is supported by haskus-system. 10 | 11 | ---------------------------------------------------------------------- 12 | haskus-elf 13 | ---------------------------------------------------------------------- 14 | 15 | ELF file viewer 16 | 17 | ---------------------------------------------------------------------- 18 | haskus-huffman 19 | ---------------------------------------------------------------------- 20 | 21 | Huffman compression tool 22 | 23 | ---------------------------------------------------------------------- 24 | haskus-gunzip 25 | ---------------------------------------------------------------------- 26 | 27 | GZIP decompression tool 28 | 29 | ---------------------------------------------------------------------- 30 | haskus-udev 31 | ---------------------------------------------------------------------- 32 | 33 | Display kernel events sent to user space 34 | 35 | ---------------------------------------------------------------------- 36 | haskus-disassembler 37 | ---------------------------------------------------------------------- 38 | 39 | x86 disassembler 40 | 41 | ---------------------------------------------------------------------- 42 | haskus-keys 43 | ---------------------------------------------------------------------- 44 | 45 | Display input events 46 | -------------------------------------------------------------------------------- /haskus-system-tools/package.yaml: -------------------------------------------------------------------------------- 1 | name: haskus-system-tools 2 | version: 0.8 3 | github: "haskus/haskus-system" 4 | license: BSD3 5 | author: "Sylvain HENRY" 6 | maintainer: "sylvain@haskus.fr" 7 | copyright: "Sylvain HENRY 2018" 8 | 9 | extra-source-files: 10 | - README.rst 11 | 12 | # Metadata used when publishing your package 13 | synopsis: System tools (x86 disassembler, etc.) 14 | category: System 15 | 16 | description: Please see the README on Github at 17 | 18 | dependencies: 19 | - base >= 4.8 && < 5 20 | - haskus-system 21 | - haskus-utils 22 | - haskus-utils-data 23 | - haskus-utils-compat 24 | - haskus-binary 25 | - optparse-applicative 26 | - happstack-server 27 | - lucid 28 | - blaze-markup 29 | - blaze-html 30 | - containers 31 | - bytestring 32 | - vector 33 | - transformers 34 | 35 | ghc-options: -Wall -O2 -threaded 36 | 37 | executables: 38 | haskus-system-info: 39 | main: Main 40 | source-dirs: src/system-info 41 | other-modules: 42 | - CmdLine 43 | dependencies: 44 | - network 45 | - HTTP 46 | 47 | haskus-elf: 48 | main: Main 49 | source-dirs: src/elf 50 | other-modules: 51 | - CmdLine 52 | dependencies: 53 | - text 54 | - formatting 55 | 56 | haskus-huffman: 57 | main: Main 58 | source-dirs: src/huffman 59 | 60 | haskus-gunzip: 61 | main: Main 62 | source-dirs: src/gunzip 63 | dependencies: 64 | - filepath 65 | 66 | haskus-udev: 67 | main: Main 68 | source-dirs: src/udev 69 | 70 | haskus-disassembler: 71 | main: Main 72 | source-dirs: src/disassembler 73 | 74 | haskus-keys: 75 | main: Main 76 | source-dirs: src/keys 77 | -------------------------------------------------------------------------------- /haskus-system-tools/src/disassembler/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Main where 4 | 5 | import System.Environment 6 | import Control.Monad (forM_) 7 | 8 | import Haskus.Format.Binary.Buffer 9 | import qualified Haskus.Format.Binary.BitSet as BitSet 10 | import Haskus.Arch.X86_64.ISA.Mode 11 | import Haskus.Arch.X86_64.ISA.Insn 12 | import Haskus.Arch.X86_64.Disassembler 13 | 14 | main :: IO () 15 | main = do 16 | [f] <- getArgs 17 | bs <- bufferReadFile f 18 | 19 | let 20 | m = ExecMode 21 | { x86Mode = LongMode Long64bitMode 22 | , csDescriptorFlagD = False 23 | , ssDescriptorFlagB = False 24 | , extensions = allExtensions 25 | } 26 | 27 | showInsn o b cmt = putStrLn str 28 | where 29 | o' = show o 30 | b' = show b 31 | fill c = replicate c ' ' 32 | str = o' 33 | ++ fill (10 - fromIntegral (length o')) 34 | ++ b' 35 | ++ fill (30 - fromIntegral (length b')) 36 | ++ cmt 37 | 38 | let 39 | ds = linearDisass m bs 40 | showDisass = \case 41 | RawBytes offset buf errs -> showInsn offset buf ("; Failed: " ++ show errs) 42 | Instruction offset buf ins -> showInsn offset buf d 43 | where 44 | d = insnMnemonic (insnSpec ins) 45 | ++ " " ++ show (insnOperands ins) 46 | ++ " " ++ show (BitSet.toList (insnVariant ins)) 47 | 48 | 49 | forM_ ds showDisass 50 | 51 | putStrLn "" 52 | putStrLn "=============================================" 53 | putStrLn "Show naive basic blocks" 54 | forM_ (findBlocks ds) $ \b -> do 55 | putStrLn "--------------------" 56 | putStrLn "BEGIN BLOCK" 57 | forM_ b showDisass 58 | putStrLn "END BLOCK" 59 | putStrLn "--------------------" 60 | -------------------------------------------------------------------------------- /haskus-system-tools/src/elf/CmdLine.hs: -------------------------------------------------------------------------------- 1 | module CmdLine 2 | ( Options(..) 3 | , getOptions 4 | ) 5 | where 6 | 7 | import Options.Applicative 8 | 9 | data Options = Options 10 | { optpath :: String 11 | , optport :: Int 12 | } 13 | 14 | options :: Parser Options 15 | options = Options 16 | <$> argument str ( 17 | metavar "PATH" 18 | <> help "Path to the binary or the project" 19 | ) 20 | <*> option auto ( 21 | long "port" 22 | <> short 'p' 23 | <> metavar "PORT" 24 | <> value 8000 25 | <> help "Use port PORT for the HTTP server" 26 | ) 27 | 28 | 29 | getOptions :: IO Options 30 | getOptions = execParser opts 31 | where 32 | opts = info (helper <*> options) 33 | ( fullDesc 34 | <> progDesc "Show information on ELF binary file" 35 | <> header "ELF info" ) 36 | -------------------------------------------------------------------------------- /haskus-system-tools/src/elf/style.css: -------------------------------------------------------------------------------- 1 | table { 2 | border: solid gray 1px; 3 | border-collapse: collapse; 4 | } 5 | 6 | td, th { 7 | border: solid gray 1px; 8 | padding-left: 1em; 9 | padding-right: 1em; 10 | } 11 | 12 | .invalid { 13 | font-style:italic; 14 | } 15 | 16 | .sym_undefined { 17 | color: blue; 18 | } 19 | 20 | .sym_absolute { 21 | color: brown; 22 | } 23 | 24 | .sym_global { 25 | color: green; 26 | } 27 | 28 | .sym_local { 29 | color: black; 30 | } 31 | 32 | .sym_weak { 33 | color: red; 34 | } 35 | -------------------------------------------------------------------------------- /haskus-system-tools/src/gunzip/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Options.Applicative 4 | import System.FilePath (replaceExtension) 5 | 6 | import Haskus.Utils.List (isSuffixOf) 7 | import Haskus.Utils.Flow (forM_,when) 8 | import qualified Haskus.Format.Compression.GZip as GZip 9 | import Haskus.Format.Binary.Buffer 10 | import qualified Haskus.Format.Text as Text 11 | 12 | main :: IO () 13 | main = do 14 | opts <- getOptions 15 | 16 | bs <- bufferReadFile (optpath opts) 17 | let ms = GZip.decompress bs 18 | forM_ ms $ \m -> do 19 | let fname = case (Text.unpack (GZip.memberName m), optpath opts) of 20 | ("",p) | ".tgz" `isSuffixOf` p -> replaceExtension p ".tar" 21 | (s,_) -> s 22 | putStrLn $ "File: " ++ fname 23 | when (fname /= "") $ do 24 | bufferWriteFile fname (GZip.memberContent m) 25 | 26 | 27 | 28 | data Options = Options 29 | { optpath :: String 30 | } 31 | 32 | options :: Parser Options 33 | options = Options 34 | <$> argument str ( 35 | metavar "PATH" 36 | <> help "Path to gzipped file" 37 | ) 38 | 39 | 40 | getOptions :: IO Options 41 | getOptions = execParser opts 42 | where 43 | opts = info (helper <*> options) 44 | ( fullDesc 45 | <> progDesc "Unzip a gzip archive" 46 | <> header "GUnzip" ) 47 | -------------------------------------------------------------------------------- /haskus-system-tools/src/huffman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Text.Printf 4 | 5 | import Haskus.Format.Compression.Algorithms.Huffman 6 | import Haskus.Format.Binary.Buffer 7 | 8 | main :: IO () 9 | main = do 10 | putStrLn "Enter the text to compress" 11 | xs <- getLine 12 | 13 | let 14 | tree = computeHuffmanTreeFromFoldable xs 15 | binTable = buildCodingTable binaryEncoder tree 16 | putStrLn "Coding:" 17 | print binTable 18 | 19 | let 20 | wbs = toBinary binTable xs 21 | r = fromIntegral (length xs) / fromIntegral (bufferSize wbs) :: Float 22 | 23 | putStrLn $ printf "Writing file (compression ratio: %.2f%%)" r 24 | bufferWriteFile "out.huff" wbs 25 | 26 | putStrLn "Reading back:" 27 | bs <- bufferReadFile "out.huff" 28 | putStrLn (fromBinaryLen True tree (length xs) bs) 29 | -------------------------------------------------------------------------------- /haskus-system-tools/src/keys/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Haskus.System.Input 6 | import Haskus.System.Event 7 | import Haskus.System.Sys 8 | import Haskus.System.Terminal 9 | import Haskus.System.Process 10 | import Haskus.System.Linux.Handle 11 | import Haskus.System.Linux.FileSystem 12 | import Haskus.Utils.Flow 13 | import qualified Haskus.Format.Binary.BitSet as BitSet 14 | 15 | import System.Environment 16 | 17 | main :: IO () 18 | main = runSys' <| do 19 | 20 | term <- defaultTerminal 21 | args <- liftIO getArgs 22 | 23 | case args of 24 | (devpath:_) -> do 25 | let flgs = BitSet.fromList [HandleReadWrite,HandleNonBlocking] 26 | hdl <- logAssertE "Open devices" <| open Nothing devpath flgs BitSet.empty 27 | 28 | eventChannel <- newEventReader hdl 29 | 30 | onEvent eventChannel <| \ev -> do 31 | let ev' = makeInputEvent ev 32 | case inputEventType ev' of 33 | InputKeyEvent action key 34 | | action /= KeyRepeat -> writeStrLn term (show key ++ ": " ++ show action) 35 | _ -> return () 36 | 37 | 38 | threadDelaySec 20 39 | 40 | _ -> writeStrLn term ("Usage: sudo haskus-keys /dev/input/event0") 41 | -------------------------------------------------------------------------------- /haskus-system-tools/src/system-info/CmdLine.hs: -------------------------------------------------------------------------------- 1 | module CmdLine 2 | ( Options(..) 3 | , getOptions 4 | ) 5 | where 6 | 7 | import Options.Applicative 8 | 9 | data Options = Options 10 | { optport :: Int 11 | } 12 | 13 | options :: Parser Options 14 | options = Options 15 | <$> option auto ( 16 | long "port" 17 | <> short 'p' 18 | <> metavar "PORT" 19 | <> value 8000 20 | <> help "Use port PORT for the HTTP server" 21 | ) 22 | 23 | 24 | getOptions :: IO Options 25 | getOptions = execParser opts 26 | where 27 | opts = info (helper <*> options) 28 | ( fullDesc 29 | <> progDesc "Haskus system info" 30 | <> header "Haskus System Info" ) 31 | -------------------------------------------------------------------------------- /haskus-system-tools/src/system-info/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family:sans-serif; 3 | background-color: #F0F0F0; 4 | font-color: #B9B9B9; 5 | } 6 | 7 | .headtitle { 8 | border: solid 1px #404040; 9 | border-radius: 5px; 10 | box-shadow: 10px 10px 5px #888888; 11 | text-align:left; 12 | padding-left: 5px; 13 | font-size:2em; 14 | color: #D0D0D0; 15 | background-color: #404040; 16 | font-family:serif; 17 | font-style:italic; 18 | margin-bottom: 15px; 19 | } 20 | 21 | h1 { 22 | text-align:center; 23 | } 24 | 25 | #buffer_alloc_size { 26 | width: 6em; 27 | } 28 | 29 | .buffer_release_form { 30 | display:inline; 31 | } 32 | 33 | .insn_table { 34 | border: 0px; 35 | border-collapse: collapse; 36 | } 37 | 38 | .insn_table td, th{ 39 | border: 1px solid black; 40 | text-align: center; 41 | } 42 | 43 | .opcode_map { 44 | border: 1px solid black; 45 | border-collapse: collapse; 46 | } 47 | 48 | .opcode_map td, th{ 49 | border: 1px solid black; 50 | text-align: center; 51 | min-width: 5em; 52 | } 53 | 54 | -------------------------------------------------------------------------------- /haskus-system-tools/src/udev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Haskus.System.Sys 4 | import Haskus.System.Network 5 | import Haskus.Utils.Flow 6 | 7 | main :: IO () 8 | main = runSys' $ do 9 | fd <- createKernelEventSocket 10 | forever $ do 11 | msg <- receiveKernelEvent fd 12 | liftIO $ putStrLn (show msg) 13 | -------------------------------------------------------------------------------- /haskus-system/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2017, Haskus organization 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | * Neither the name of Sylvain Henry nor the names of other contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE FOR ANY DIRECT, 22 | INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 23 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 24 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 25 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 26 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 27 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Apps/CPIO.hs: -------------------------------------------------------------------------------- 1 | -- | CPIO encoder/decoder app 2 | module Haskus.Apps.CPIO 3 | ( archiveFiles 4 | ) 5 | where 6 | 7 | import Haskus.Format.CPIO 8 | import Haskus.Format.Binary.Buffer 9 | import Haskus.Format.Binary.Put 10 | import Haskus.Format.Binary.BitSet as BitSet 11 | import qualified Haskus.Format.Text as Text 12 | import Haskus.System.Linux.FileSystem 13 | import Haskus.Utils.Flow 14 | 15 | import System.FilePath 16 | 17 | -- | Archive several files in a CPIO archive using dummy metadata 18 | -- 19 | -- TODO: 20 | -- * handle hard links 21 | -- * handle directories 22 | -- * use real inode, dev, UID, GID and modiftime 23 | -- * don't load all the files at once in memory 24 | archiveFiles :: FilePath -> [FilePath] -> IO () 25 | archiveFiles dest files = do 26 | 27 | -- generate headers 28 | let 29 | makeHdr n = FileDesc 30 | { fileInode = n 31 | , fileMode = fmod 32 | , fileUID = 0 33 | , fileGID = 0 34 | , fileNLink = 1 35 | , fileModifTime = 0 36 | , fileDevMajor = 0 37 | , fileDevMinor = 0 38 | , fileRDevMajor = 0 39 | , fileRDevMinor = 0 40 | } 41 | fmod = makeMode FileTypeFile (BitSet.fromList [PermUserRead]) BitSet.empty 42 | hds = fmap makeHdr [1..] 43 | names = fmap (Text.pack . takeFileName) files 44 | 45 | -- read files 46 | bufs <- forM files bufferReadFile 47 | 48 | -- write output file 49 | let out = runPut $ putFiles (zip3 hds names bufs) 50 | bufferWriteFile dest out 51 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Apps/Disassembler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Haskus.Apps.Disassembler 4 | ( disassX86_64 5 | ) 6 | where 7 | 8 | 9 | import qualified Haskus.Format.Text as Text 10 | import Haskus.Format.Text (Text) 11 | import Haskus.Format.Binary.Buffer 12 | import qualified Haskus.Format.Binary.BitSet as BitSet 13 | import Haskus.Arch.X86_64.ISA.Mode 14 | import Haskus.Arch.X86_64.ISA.Size 15 | import Haskus.Arch.X86_64.ISA.Insn 16 | import Haskus.Arch.X86_64.ISA.Encoding 17 | import Haskus.Arch.X86_64.ISA.Register 18 | import Haskus.Arch.X86_64.ISA.Immediate 19 | import Haskus.Arch.X86_64.ISA.Memory 20 | import Haskus.Arch.Common.Memory 21 | import Haskus.Arch.X86_64.ISA.Operand 22 | import Haskus.Arch.X86_64.Disassembler 23 | import Haskus.Utils.List 24 | import Haskus.Utils.Maybe 25 | 26 | import Data.Text.Lazy.Builder 27 | import qualified Data.Text.Lazy as LT 28 | import Numeric (showHex) 29 | 30 | -- | Disassemble a buffer containing X86-64 assembly. 31 | -- Enable all the extensions 32 | disassX86_64 :: Maybe Word -> Buffer -> Text 33 | disassX86_64 initOffset buffer = LT.toStrict (toLazyText bld) 34 | where 35 | -- disassembled buffer 36 | ds = linearDisass m buffer 37 | 38 | -- arch mode 39 | m = ExecMode 40 | { x86Mode = LongMode Long64bitMode 41 | , csDescriptorFlagD = False 42 | , ssDescriptorFlagB = False 43 | , extensions = allExtensions 44 | } 45 | 46 | -- builder 47 | bld = mconcat (fmap (fromText . showDisass) ds) 48 | 49 | 50 | -- show an instruction 51 | showInsn o b cmt = Text.pack str 52 | where 53 | o' = showHex (fromMaybe 0 initOffset + o) "" 54 | b' = show b 55 | fill c = replicate c ' ' 56 | str = o' 57 | ++ fill (17 - fromIntegral (length o')) 58 | ++ b' 59 | ++ fill (30 - fromIntegral (length b')) 60 | ++ cmt 61 | ++ "\n" 62 | 63 | -- show a disassembled entry 64 | showDisass = \case 65 | RawBytes offset buf _ -> showInsn offset buf "; raw bytes" 66 | Instruction offset buf ins -> showInsn offset buf $ 67 | (if not (BitSet.null (insnVariant ins)) 68 | then show (BitSet.toList (insnVariant ins)) ++ " " 69 | else "" 70 | ) 71 | ++ insnMnemonic (insnSpec ins) 72 | ++ " " 73 | ++ concat (intersperse ", " (fmap (uncurry showAsmOperand) 74 | (insnOperands ins `zip` encOperands (insnEncoding ins)))) 75 | 76 | showAsmOperand :: Operand -> OperandSpec t -> String 77 | showAsmOperand op enc = fimp $ case op of 78 | OpImm v -> showAsmImm v 79 | OpMem m -> showAsmMem m 80 | OpReg reg -> showAsmReg reg 81 | OpRegPair r1 r2 -> showAsmReg r1 ++ ":" ++ showAsmReg r2 82 | OpImmPair i1 i2 -> showAsmImm i1 ++ ":" ++ showAsmImm i2 83 | where 84 | fimp x 85 | | opStore enc == S_Implicit = "{" ++ x ++ "}" 86 | | otherwise = x 87 | 88 | -- TODO: show mem type 89 | showAsmMem :: X86Mem -> String 90 | showAsmMem m = cs ++ "[" ++ xs ++ "]" 91 | where 92 | a = memAddr m 93 | cs = fromMaybe "" (fmap ((++":").showAsmReg) (addrSeg a)) 94 | xs = concat (intersperse " + " (catMaybes [bs, is, ds])) 95 | bs = showAsmReg <$> addrBase a 96 | is = case (addrIndex a, addrScale a) of 97 | (Nothing, _) -> Nothing 98 | (Just i, Just Scale1) -> Just (showAsmReg i) 99 | (Just i, Nothing) -> Just (showAsmReg i) 100 | (Just i, Just Scale2) -> Just (showAsmReg i >> "*2") 101 | (Just i, Just Scale4) -> Just (showAsmReg i >> "*4") 102 | (Just i, Just Scale8) -> Just (showAsmReg i >> "*8") 103 | ds = (show . fromSizedValue) <$> addrDisp a 104 | 105 | showAsmImm :: X86Imm -> String 106 | showAsmImm = show . immValue 107 | 108 | showAsmReg :: X86Reg -> String 109 | showAsmReg reg = registerName reg 110 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/Common/Immediate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | 10 | -- - Immediate operand 11 | module Haskus.Arch.Common.Immediate 12 | ( Imm (..) 13 | , ImmFam (..) 14 | , ImmFamT 15 | , ImmFamP 16 | , immFamToImm 17 | ) 18 | where 19 | 20 | import Haskus.Format.Binary.Word 21 | import Haskus.Arch.Common.Solver 22 | import Haskus.Utils.Solver 23 | import Haskus.Utils.Flow 24 | import Haskus.Utils.List (nub) 25 | 26 | -- | Immediate value 27 | data Imm it s = Imm 28 | { immSize :: !s -- ^ Size of the immediate 29 | , immSignExtended :: !(Maybe s) -- ^ Sign-extended to the given size 30 | , immValue :: !Word64 -- ^ Value of the immediate 31 | , immType :: !(Maybe it) -- ^ Type of the immediate 32 | } 33 | deriving (Show,Eq) 34 | 35 | -- | Immediate family 36 | data ImmFam t it s = ImmFam 37 | { immFamSize :: !(Q t s) -- ^ Size of the immediate 38 | , immFamSignExtended :: !(Q t (Maybe s)) -- ^ Sign-extended to the given size 39 | , immFamValue :: !(Q t (Maybe Word64)) -- ^ Value of the immediate 40 | , immFamType :: !(Q t (Maybe it)) -- ^ Type of the immediate 41 | } 42 | 43 | -- | Predicated immediate family 44 | type ImmFamP p e it s = ImmFam (NT p e) it s 45 | 46 | -- | Terminal immediate family 47 | type ImmFamT it s = ImmFam T it s 48 | 49 | deriving instance (Show it, Show s) => Show (ImmFam T it s) 50 | deriving instance (Eq it, Eq s) => Eq (ImmFam T it s) 51 | deriving instance (Ord it, Ord s) => Ord (ImmFam T it s) 52 | deriving instance (Show p, Show e, Show it, Show s) => Show (ImmFam (NT p e) it s) 53 | deriving instance (Eq p, Eq e, Eq it, Eq s) => Eq (ImmFam (NT p e) it s) 54 | deriving instance (Ord p, Ord e, Ord it, Ord s) => Ord (ImmFam (NT p e) it s) 55 | 56 | instance (Ord p, Eq e, Eq i, Eq s, Eq p) => Predicated (ImmFam (NT p e) i s) where 57 | type Pred (ImmFam (NT p e) i s) = p 58 | type PredErr (ImmFam (NT p e) i s) = e 59 | type PredTerm (ImmFam (NT p e) i s) = ImmFam T i s 60 | 61 | liftTerminal (ImmFam s e v t) = ImmFam (liftTerminal s) 62 | (liftTerminal e) 63 | (liftTerminal v) 64 | (liftTerminal t) 65 | 66 | reducePredicates oracle (ImmFam s e v t) = 67 | initP ImmFam ImmFam 68 | |> (`applyP` reducePredicates oracle s) 69 | |> (`applyP` reducePredicates oracle e) 70 | |> (`applyP` reducePredicates oracle v) 71 | |> (`applyP` reducePredicates oracle t) 72 | |> resultP 73 | 74 | getTerminals (ImmFam ss es vs ts) = 75 | [ ImmFam s e v t | s <- getTerminals ss 76 | , e <- getTerminals es 77 | , v <- getTerminals vs 78 | , t <- getTerminals ts 79 | ] 80 | 81 | getPredicates (ImmFam s e v t) = 82 | nub $ concat [ getPredicates s 83 | , getPredicates e 84 | , getPredicates v 85 | , getPredicates t 86 | ] 87 | 88 | 89 | -- | Convert an immediate family into an immediate 90 | immFamToImm :: ImmFamT it s -> Maybe (Imm it s) 91 | immFamToImm ImmFam{..} = case immFamValue of 92 | Nothing -> Nothing 93 | Just v -> Just (Imm immFamSize immFamSignExtended v immFamType) 94 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/Common/Memory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | 10 | -- | Register 11 | module Haskus.Arch.Common.Memory 12 | ( Mem (..) 13 | , MemFam (..) 14 | , MemFamP 15 | , MemFamT 16 | , memFamToMem 17 | ) 18 | where 19 | 20 | import Haskus.Arch.Common.Solver 21 | import Haskus.Utils.Solver 22 | import Haskus.Utils.Flow 23 | import Haskus.Utils.List (nub) 24 | 25 | -- | Data in memory 26 | data Mem addr mtype = Mem 27 | { memAddr :: addr -- ^ Memory address 28 | , memType :: mtype -- ^ Memory type 29 | , memSize :: {-# UNPACK #-} !Word -- ^ Memory size in bits 30 | } 31 | deriving (Show,Eq,Ord) 32 | 33 | 34 | -- | Memory family 35 | -- 36 | -- All the fields are predicated. 37 | -- The memory address may be set or not (it is set in implicit operands for 38 | -- instance). The size may be set or not (it can't be set for instructions 39 | -- depending on runtime values, e.g., XSAVE state). 40 | data MemFam t addr mtype = MemFam 41 | { memFamAddr :: !(Q t (Maybe addr)) -- ^ Memory address 42 | , memFamType :: !(Q t mtype) -- ^ Memory type 43 | , memFamSize :: !(Q t (Maybe Word)) -- ^ Memory size in bits 44 | } 45 | 46 | -- | Convert a memory family to a memory 47 | memFamToMem :: MemFamT a m -> Maybe (Mem a m) 48 | memFamToMem MemFam{..} = 49 | Mem <$> memFamAddr 50 | <*> Just memFamType 51 | <*> memFamSize 52 | 53 | -- | Predicated memory family 54 | type MemFamP p e a m = MemFam (NT p e) a m 55 | 56 | -- | Terminal memory family 57 | type MemFamT a m = MemFam T a m 58 | 59 | deriving instance (Show a, Show m) => Show (MemFam T a m) 60 | deriving instance (Eq a, Eq m) => Eq (MemFam T a m) 61 | deriving instance (Ord a, Ord m) => Ord (MemFam T a m) 62 | deriving instance (Show p, Show e, Show a, Show m) => Show (MemFam (NT p e) a m) 63 | deriving instance (Eq p, Eq e, Eq a, Eq m) => Eq (MemFam (NT p e) a m) 64 | deriving instance (Ord p, Ord e, Ord a, Ord m) => Ord (MemFam (NT p e) a m) 65 | 66 | instance (Ord p, Eq e, Eq a, Eq m, Eq p) => Predicated (MemFam (NT p e) a m) where 67 | type Pred (MemFam (NT p e) a m) = p 68 | type PredErr (MemFam (NT p e) a m) = e 69 | type PredTerm (MemFam (NT p e) a m) = MemFam T a m 70 | 71 | liftTerminal (MemFam a t s) = MemFam (liftTerminal a) 72 | (liftTerminal t) 73 | (liftTerminal s) 74 | 75 | reducePredicates oracle (MemFam a t s) = 76 | initP MemFam MemFam 77 | |> (`applyP` reducePredicates oracle a) 78 | |> (`applyP` reducePredicates oracle t) 79 | |> (`applyP` reducePredicates oracle s) 80 | |> resultP 81 | 82 | getTerminals (MemFam as ts ss) = 83 | [ MemFam a t s| a <- getTerminals as 84 | , t <- getTerminals ts 85 | , s <- getTerminals ss 86 | ] 87 | 88 | getPredicates (MemFam a t s) = 89 | nub $ concat [ getPredicates a 90 | , getPredicates t 91 | , getPredicates s 92 | ] 93 | 94 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/Common/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | -- | Solver utils 4 | module Haskus.Arch.Common.Solver 5 | ( Q 6 | , T 7 | , NT 8 | ) 9 | where 10 | 11 | import Haskus.Utils.Solver 12 | 13 | data T -- terminal 14 | data NT p e -- non-terminal 15 | 16 | type family Q t a :: * where 17 | Q (NT p e) a = Rule e p a 18 | Q T a = a 19 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/Disassembler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -- | X86 disassembler 4 | module Haskus.Arch.X86_64.Disassembler 5 | ( Disass (..) 6 | , linearDisass 7 | , findBlocks 8 | ) 9 | where 10 | 11 | import Haskus.Format.Binary.Get as G 12 | import Haskus.Format.Binary.Buffer 13 | import Haskus.Arch.X86_64.ISA.Insn 14 | import Haskus.Arch.X86_64.ISA.Mode 15 | import Haskus.Arch.X86_64.ISA.Decoder 16 | import Haskus.Utils.List (intersect) 17 | 18 | data Disass 19 | = RawBytes Word Buffer [String] 20 | | Instruction Word Buffer Insn 21 | deriving (Show) 22 | 23 | -- | Disassemble a whole buffer linearly 24 | linearDisass :: ExecMode -> Buffer -> [Disass] 25 | linearDisass m = go 0 emptyBuffer [] 26 | 27 | where 28 | g = G.countBytes $ getInstruction m 29 | 30 | go offset fb fbs b 31 | | isBufferEmpty b && isBufferEmpty fb = [] 32 | | isBufferEmpty b = [RawBytes (offset - bufferSize fb) fb fbs] 33 | 34 | go offset fb fbs b = case G.runGet g b of 35 | Left str -> go (offset+1) (bufferSnoc fb (bufferHead b)) 36 | (reverse (str:fbs)) (bufferTail b) 37 | Right (n,i) -> x ++ go (offset + n) emptyBuffer [] (bufferDrop n b) 38 | where 39 | x = if isBufferEmpty fb 40 | then [s] 41 | else [RawBytes (offset - bufferSize fb) fb (reverse fbs), s] 42 | s = Instruction offset (bufferTake n b) i 43 | 44 | 45 | -- | Find basic blocks by looking at branching/calls 46 | -- Warning: we don't look at branch targets! 47 | findBlocks :: [Disass] -> [[Disass]] 48 | findBlocks = go [] 49 | where 50 | go [] [] = [] 51 | go bs [] = [reverse bs] 52 | go bs (d@RawBytes {}:ds) = go (d:bs) ds 53 | go bs (d@(Instruction _ _ i):ds) = 54 | if null (insnFamilies (insnSpec i) 55 | `intersect` [Call,Branch,ConditionalBranch,Return]) 56 | then go (d:bs) ds 57 | else reverse (d:bs) : go [] ds 58 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/ISA/Immediate.hs: -------------------------------------------------------------------------------- 1 | -- | Immediate operand 2 | module Haskus.Arch.X86_64.ISA.Immediate 3 | ( X86ImmFamP 4 | , X86ImmFamT 5 | , X86ImmFam 6 | , X86Imm 7 | , Imm (..) 8 | , immFamFixedSize 9 | , immFamOpSize 10 | , immFamOpSizeSE 11 | , immFamConst 12 | ) 13 | where 14 | 15 | import Haskus.Arch.X86_64.ISA.Size 16 | import Haskus.Arch.X86_64.ISA.Solver 17 | import Haskus.Arch.Common.Immediate 18 | import Haskus.Utils.Solver 19 | import Haskus.Format.Binary.Word 20 | 21 | data ImmType 22 | = ImmGeneric 23 | deriving (Show,Eq,Ord) 24 | 25 | type X86ImmFamP = ImmFamP X86Pred X86Err ImmType OperandSize 26 | type X86ImmFamT = ImmFamT ImmType OperandSize 27 | type X86ImmFam t = ImmFam t ImmType OperandSize 28 | type X86Imm = Imm ImmType OperandSize 29 | 30 | -- | Fixed size immediate 31 | immFamFixedSize :: OperandSize -> X86ImmFamP 32 | immFamFixedSize s = ImmFam 33 | { immFamSize = Terminal s 34 | , immFamSignExtended = Terminal Nothing 35 | , immFamValue = Terminal Nothing 36 | , immFamType = Terminal Nothing 37 | } 38 | 39 | -- | Operand-sized immediate 40 | immFamOpSize :: X86ImmFamP 41 | immFamOpSize = ImmFam 42 | { immFamSize = pOpSize64 OpSize8 OpSize16 OpSize32 OpSize64 43 | , immFamSignExtended = Terminal Nothing 44 | , immFamValue = Terminal Nothing 45 | , immFamType = Terminal (Just ImmGeneric) 46 | } 47 | 48 | -- | Operand-sized immediate (size-extendable if the bit is set or in 64-bit 49 | -- mode) 50 | immFamOpSizeSE :: X86ImmFamP 51 | immFamOpSizeSE = ImmFam 52 | { immFamSize = orderedNonTerminal 53 | [ (pForce8bit , Terminal OpSize8) 54 | , (pSignExtendBit , Terminal OpSize8) 55 | , (pOverriddenOperationSize64 OpSize16, Terminal OpSize16) 56 | , (pOverriddenOperationSize64 OpSize32, Terminal OpSize32) 57 | , (pOverriddenOperationSize64 OpSize64, Terminal OpSize32) -- sign-extend 58 | ] 59 | , immFamSignExtended = orderedNonTerminal 60 | [ (pOverriddenOperationSize64 OpSize64, Terminal $ Just OpSize64) 61 | , (pSignExtendBit , NonTerminal 62 | [ (pOverriddenOperationSize64 OpSize16, Terminal $ Just OpSize16) 63 | , (pOverriddenOperationSize64 OpSize32, Terminal $ Just OpSize32) 64 | ]) 65 | , (CBool True , Terminal Nothing) 66 | ] 67 | , immFamValue = Terminal Nothing 68 | , immFamType = Terminal (Just ImmGeneric) 69 | } 70 | 71 | 72 | -- | Constant immediate 73 | immFamConst :: OperandSize -> Word64 -> X86ImmFamP 74 | immFamConst s v = ImmFam 75 | { immFamSize = Terminal s 76 | , immFamSignExtended = Terminal Nothing 77 | , immFamValue = Terminal (Just v) 78 | , immFamType = Terminal Nothing 79 | } 80 | 81 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/ISA/Insn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | module Haskus.Arch.X86_64.ISA.Insn 4 | ( EncodingVariant(..) 5 | , Insn (..) 6 | , X86Insn(..) 7 | , Properties (..) 8 | , FlagOp(..) 9 | , Flag (..) 10 | , InsnFamily (..) 11 | ) 12 | where 13 | 14 | import Haskus.Format.Binary.BitSet (BitSet,CBitSet) 15 | import Haskus.Format.Binary.Word 16 | import Haskus.Arch.X86_64.ISA.Encoding 17 | import Haskus.Arch.X86_64.ISA.Operand 18 | 19 | data Insn = Insn 20 | { insnOpcode :: Opcode 21 | , insnOperands :: [Operand] 22 | , insnEncoding :: Encoding 23 | , insnSpec :: X86Insn 24 | , insnVariant :: BitSet Word16 EncodingVariant 25 | } 26 | deriving (Show) 27 | 28 | -- | Instruction variant encoding 29 | data EncodingVariant 30 | = Locked -- ^ Locked memory access 31 | | Reversed -- ^ Parameters are reversed (useful when some instructions have two valid encodings, e.g. CMP reg8, reg8) 32 | | ExplicitParam -- ^ A variant exists with an implicit parameter, but the explicit variant is used 33 | | RepeatZero -- ^ REP(Z) prefix 34 | | RepeatNonZero -- ^ REPNZ prefix 35 | | LockEllisionAcquire -- ^ XACQUIRE prefix 36 | | LockEllisionRelease -- ^ XRELEASE prefix 37 | | BranchHintTaken -- ^ Branch hint (branch taken) 38 | | BranchHintNotTaken -- ^ Branch hint (not taken) 39 | | SuperfluousSegmentOverride -- ^ Segment override equal to default segment 40 | deriving (Show,Eq,Enum,CBitSet) 41 | 42 | 43 | -- | X86 instruction 44 | data X86Insn = X86Insn 45 | { insnDesc :: String 46 | , insnMnemonic :: String 47 | , insnProperties :: [Properties] 48 | , insnFamilies :: [InsnFamily] 49 | , insnFlags :: [FlagOp Flag] 50 | , insnEncodings :: [Encoding] 51 | } deriving (Show) 52 | 53 | -- | Instruction properties 54 | data Properties 55 | = FailOnZero Int -- ^ Fail if the n-th parameter (indexed from 0) is 0 56 | | MemAlign Int -- ^ Memory alignment constraint in bytes 57 | | MemAlignDefault -- ^ Memory alignment constraint 58 | deriving (Show,Eq) 59 | 60 | -- | Instruction taxonomy 61 | data InsnFamily 62 | = Call -- ^ Call-like instruction (branch then return to the next instruction) 63 | | Return -- ^ Return from a call, an interruption, etc. 64 | | Branch -- ^ Unconditional branch instruction 65 | | ConditionalBranch -- ^ Conditional branch instruction 66 | deriving (Show,Eq) 67 | 68 | -- | Flag state modification 69 | data FlagOp a 70 | = St [a] -- ^ Set flag to 1 71 | | Unset [a] -- ^ Set flag to 0 72 | | Modified [a] -- ^ Set flag depending on the result 73 | | Undefined [a] -- ^ Flag is undefined after the operation 74 | | Read [a] -- ^ Flag read by the instruction 75 | deriving (Show,Eq) 76 | 77 | -- | Status flag 78 | data Flag 79 | -- Status flag 80 | = CF -- ^ Carry flag 81 | | PF -- ^ Parity flag 82 | | AF -- ^ Adjust flag 83 | | ZF -- ^ Zero flag 84 | | SF -- ^ Sign flag 85 | | TF -- ^ Trap flag 86 | | OF -- ^ Overflow flag 87 | 88 | -- Control flags 89 | | DF -- ^ Direction flag 90 | | IF -- ^ Interrupt flag 91 | | AC -- ^ Alignment check 92 | deriving (Show,Enum,Eq) 93 | 94 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/ISA/MicroArch.hs: -------------------------------------------------------------------------------- 1 | -- | X86 Archtiectures and micro-architectures 2 | module Haskus.Arch.X86_64.ISA.MicroArch 3 | ( X86Arch(..) 4 | ) 5 | where 6 | 7 | -- | X86 micro-architecture 8 | data X86Arch 9 | = Intel486 10 | | IntelPentium 11 | | IntelP6 12 | deriving (Show,Eq) 13 | 14 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/ISA/OpcodeMaps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | -- | Opcode tables 5 | module Haskus.Arch.X86_64.ISA.OpcodeMaps 6 | ( opcodeMaps 7 | , buildOpcodeMaps 8 | , buildOpcodeMap 9 | , MapEntry (..) 10 | ) 11 | where 12 | 13 | import Haskus.Arch.X86_64.ISA.Insns 14 | import Haskus.Arch.X86_64.ISA.Insn 15 | import Haskus.Arch.X86_64.ISA.Encoding 16 | import Haskus.Utils.Maybe 17 | 18 | import qualified Data.Map as Map 19 | import Data.Map (Map) 20 | import qualified Data.Vector as V 21 | 22 | -- | Entry in the opcode table 23 | data MapEntry = MapEntry 24 | { entryInsn :: X86Insn -- ^ Instruction 25 | , entryEncoding :: Encoding -- ^ Encoding 26 | } 27 | deriving (Show) 28 | 29 | -- | Build an opcode map 30 | buildOpcodeMap :: [MapEntry] -> V.Vector [MapEntry] 31 | buildOpcodeMap entries = as 32 | where 33 | -- all pairs (opcode, MapEntry) 34 | es = [(oc,[e]) | e <- entries 35 | , oc <- encGenerateOpcodes (entryEncoding e) 36 | ] 37 | 38 | -- Map opcode [MapEntry] 39 | ks = Map.fromListWith (++) es 40 | 41 | -- Vector 42 | as = V.generate 256 (fromMaybe [] . (`Map.lookup` ks) . fromIntegral) 43 | 44 | -- | Build opcode maps 45 | buildOpcodeMaps :: [X86Insn] -> Map OpcodeMap (V.Vector [MapEntry]) 46 | buildOpcodeMaps is = buildOpcodeMap <$> Map.fromListWith (++) es 47 | where 48 | -- all map entries 49 | es = [ (encOpcodeMap e,[MapEntry i e]) | i <- is 50 | , e <- insnEncodings i 51 | ] 52 | -- | Opcode maps 53 | opcodeMaps :: Map OpcodeMap (V.Vector [MapEntry]) 54 | opcodeMaps = buildOpcodeMaps instructions 55 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/ISA/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -- | Sizes 4 | module Haskus.Arch.X86_64.ISA.Size 5 | ( Size(..) 6 | , sizeInBits 7 | , AddressSize(..) 8 | , SizedValue(..) 9 | , toSizedValue 10 | , fromSizedValue 11 | , OperandSize(..) 12 | , opSizeInBits 13 | , getSize 14 | , getSize64 15 | , getOpSize64 16 | ) where 17 | 18 | import Haskus.Format.Binary.Get 19 | import Haskus.Format.Binary.Word 20 | 21 | -- | Size 22 | data Size 23 | = Size8 24 | | Size16 25 | | Size32 26 | | Size64 27 | | Size128 28 | | Size256 29 | | Size512 30 | deriving (Show,Eq,Ord) 31 | 32 | -- | Get a size in bits 33 | sizeInBits :: Size -> Word 34 | sizeInBits = \case 35 | Size8 -> 8 36 | Size16 -> 16 37 | Size32 -> 32 38 | Size64 -> 64 39 | Size128 -> 128 40 | Size256 -> 256 41 | Size512 -> 512 42 | 43 | -- | Address size 44 | data AddressSize 45 | = AddrSize16 46 | | AddrSize32 47 | | AddrSize64 48 | deriving (Show,Eq,Ord) 49 | 50 | -- | Sized value 51 | data SizedValue 52 | = SizedValue8 !Word8 53 | | SizedValue16 !Word16 54 | | SizedValue32 !Word32 55 | | SizedValue64 !Word64 56 | deriving (Show,Eq,Ord) 57 | 58 | -- | Convert a value into a SizedValue 59 | toSizedValue :: Size -> Word64 -> SizedValue 60 | toSizedValue s v = case s of 61 | Size8 -> SizedValue8 (fromIntegral v) 62 | Size16 -> SizedValue16 (fromIntegral v) 63 | Size32 -> SizedValue32 (fromIntegral v) 64 | Size64 -> SizedValue64 (fromIntegral v) 65 | _ -> error ("toSizedValue: invalid size (" ++ show s ++ ")") 66 | 67 | -- | Convert a value from a SizedValue 68 | fromSizedValue :: SizedValue -> Word64 69 | fromSizedValue = \case 70 | SizedValue8 v -> fromIntegral v 71 | SizedValue16 v -> fromIntegral v 72 | SizedValue32 v -> fromIntegral v 73 | SizedValue64 v -> v 74 | 75 | -- | Operand size 76 | data OperandSize 77 | = OpSize8 78 | | OpSize16 79 | | OpSize32 80 | | OpSize64 81 | deriving (Show,Eq,Ord) 82 | 83 | -- | Operand size in bits 84 | opSizeInBits :: OperandSize -> Word 85 | opSizeInBits = \case 86 | OpSize8 -> 8 87 | OpSize16 -> 16 88 | OpSize32 -> 32 89 | OpSize64 -> 64 90 | 91 | -- | Read a SizedValue 92 | getSize :: Size -> Get SizedValue 93 | getSize Size8 = SizedValue8 <$> getWord8 94 | getSize Size16 = SizedValue16 <$> getWord16le 95 | getSize Size32 = SizedValue32 <$> getWord32le 96 | getSize Size64 = SizedValue64 <$> getWord64le 97 | getSize s = error ("getSize: unsupported size: " ++ show s) 98 | 99 | -- | Read a value in a Word64 100 | getSize64 :: Size -> Get Word64 101 | getSize64 Size8 = fromIntegral <$> getWord8 102 | getSize64 Size16 = fromIntegral <$> getWord16le 103 | getSize64 Size32 = fromIntegral <$> getWord32le 104 | getSize64 Size64 = getWord64le 105 | getSize64 s = error ("getSize: unsupported size: " ++ show s) 106 | 107 | -- | Read a value in a Word64 108 | getOpSize64 :: OperandSize -> Get Word64 109 | getOpSize64 OpSize8 = fromIntegral <$> getWord8 110 | getOpSize64 OpSize16 = fromIntegral <$> getWord16le 111 | getOpSize64 OpSize32 = fromIntegral <$> getWord32le 112 | getOpSize64 OpSize64 = getWord64le 113 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/Linux/SyscallTable.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Arch.X86_64.Linux.SyscallTable 2 | ( syscalls 3 | ) 4 | where 5 | 6 | import Haskus.Utils.Flow 7 | import Haskus.Utils.Maybe 8 | 9 | import Language.Haskell.TH.Quote 10 | import Language.Haskell.TH.Syntax 11 | 12 | import Text.Megaparsec 13 | import Text.Megaparsec.Char.Lexer hiding (space) 14 | import Text.Megaparsec.Char 15 | import Data.Void 16 | 17 | type Parser = Parsec Void String 18 | 19 | syscalls :: QuasiQuoter 20 | syscalls = QuasiQuoter 21 | { quoteDec = makeSyscalls 22 | , quoteExp = undefined 23 | , quotePat = undefined 24 | , quoteType = undefined 25 | } 26 | 27 | makeSyscalls :: String -> Q [Dec] 28 | makeSyscalls str = 29 | case runParser parseLines "syscalls table" str of 30 | Right entries -> return (concatMap makeSyscall entries) 31 | Left err -> fail (show err) 32 | 33 | type Entry = (Integer,String,String,[[String]]) 34 | 35 | makeSyscall :: Entry -> [Dec] 36 | makeSyscall (num,mode,name,typ) = [sysSig,sysFun] 37 | where 38 | arity = length typ - 1 39 | syscallN = mkName <| mconcat 40 | [ "syscall" 41 | , show arity 42 | , case mode of 43 | "PrimOp" -> "primop" 44 | "Safe" -> "safe" 45 | r -> fail ("Invalid syscall mode: " ++ r) 46 | ] 47 | 48 | makeType :: [[String]] -> Type 49 | makeType xs = 50 | xs ||> fmap (ConT . mkName) 51 | ||> foldl1 AppT 52 | |> foldr1 (\x y -> AppT (AppT ArrowT x) y) 53 | 54 | sysName = mkName ("syscall_"++name) 55 | 56 | sysFun = FunD sysName 57 | [ Clause [] 58 | (NormalB (AppE (VarE syscallN) (LitE (IntegerL num)))) 59 | [] 60 | ] 61 | sysSig = SigD sysName (makeType typ) 62 | 63 | -- | Parse a line with the form: 64 | -- num mode name :: type 65 | -- e.g. 66 | -- 4 PrimOp stat :: CString -> Ptr () -> IO Int64 67 | parseLines :: Parser [(Integer,String,String,[[String]])] 68 | parseLines = catMaybes <$> lines' 69 | where 70 | lines' = (line `sepEndBy` eol) <* eof 71 | 72 | line = manySpace *> 73 | ( (Just <$> try entryLine) 74 | <|> (try comment >> return Nothing) 75 | <|> (lookAhead end >> return Nothing) 76 | ) 77 | 78 | entryLine = do 79 | num <- decimal 80 | someSpace 81 | mode <- some alphaNumChar 82 | someSpace 83 | name <- identifier 84 | manySpace 85 | void (string "::") 86 | manySpace 87 | typ <- (typElem `sepEndBy` manySpace) `sepBy` arrow 88 | manySpace 89 | lookAhead end 90 | return (num,mode,name,typ) 91 | 92 | end = void eol <|> eof 93 | arrow = void (string "->") >> manySpace 94 | 95 | identifier = some (alphaNumChar <|> char '_') 96 | typElem = identifier <|> string "()" 97 | 98 | 99 | -- 'space' from MegaParsec also considers line-breaks as spaces... 100 | manySpace = skipMany (char ' ') 101 | someSpace = skipSome (char ' ') 102 | 103 | comment = do 104 | void (string "--") 105 | anySingle `manyTill` lookAhead end 106 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/Linux/syscall.s: -------------------------------------------------------------------------------- 1 | /************************************************* 2 | * Convertion between x86-64 calling convention 3 | * and Linux (64 bits) system call convention 4 | * *********************************************** 5 | * 6 | * x86-64: 7 | * Parameters: rdi, rsi, rdx, rcx, r8, r9 8 | * Values returned: rax, rdx 9 | * Caller-save: rax, rdi, rsi, rdx, rcx, r8, r9, r10, r11 10 | * Callee-save: rbx, rsp, rbp, r12, r13, r14, r15 11 | * 12 | * Linux: 13 | * Parameters: rax (syscall number), rdi, rsi, rdx, r10, r8, r9 14 | * Value returned: rax 15 | * Caller-save: rcx, r11 16 | */ 17 | 18 | .global x86_64_linux_syscall6 19 | x86_64_linux_syscall6: 20 | movq %rdi, %rax 21 | movq %rsi, %rdi 22 | movq %rdx, %rsi 23 | movq %rcx, %rdx 24 | movq %r8, %r10 25 | movq %r9, %r8 26 | movq 8(%rsp),%r9 27 | syscall 28 | retq 29 | 30 | .global x86_64_linux_syscall5 31 | x86_64_linux_syscall5: 32 | movq %rdi, %rax 33 | movq %rsi, %rdi 34 | movq %rdx, %rsi 35 | movq %rcx, %rdx 36 | movq %r8, %r10 37 | movq %r9, %r8 38 | syscall 39 | retq 40 | 41 | .global x86_64_linux_syscall4 42 | x86_64_linux_syscall4: 43 | movq %rdi, %rax 44 | movq %rsi, %rdi 45 | movq %rdx, %rsi 46 | movq %rcx, %rdx 47 | movq %r8, %r10 48 | syscall 49 | retq 50 | 51 | .global x86_64_linux_syscall3 52 | x86_64_linux_syscall3: 53 | movq %rdi, %rax 54 | movq %rsi, %rdi 55 | movq %rdx, %rsi 56 | movq %rcx, %rdx 57 | syscall 58 | retq 59 | 60 | .global x86_64_linux_syscall2 61 | x86_64_linux_syscall2: 62 | movq %rdi, %rax 63 | movq %rsi, %rdi 64 | movq %rdx, %rsi 65 | syscall 66 | retq 67 | 68 | .global x86_64_linux_syscall1 69 | x86_64_linux_syscall1: 70 | movq %rdi, %rax 71 | movq %rsi, %rdi 72 | syscall 73 | retq 74 | 75 | .global x86_64_linux_syscall0 76 | x86_64_linux_syscall0: 77 | movq %rdi, %rax 78 | syscall 79 | retq 80 | 81 | /********************************************************** 82 | * Convertion between GHC STG calling convention on x86-64 83 | * and Linux (64 bits) system call convention 84 | * ******************************************************** 85 | * 86 | * STG: 87 | * Virtual registers: Base, Sp, Hp, R1-R6, SpLim 88 | * Registers: r13, rbp, r12, rbx, r14, rsi, rdi, r8, r9, r15 89 | * Use tail-call (jump) to Sp[0] to exit a function, so the 90 | * "return value" is to be stored in rbx (and following if we 91 | * want to return a tuple) 92 | * 93 | * Linux: 94 | * Parameters: rax (syscall number), rdi, rsi, rdx, r10, r8, r9 95 | * Value returned: rax 96 | * Caller-save: rcx, r11 97 | */ 98 | 99 | .global x86_64_linux_syscall_primop6 100 | x86_64_linux_syscall_primop6: 101 | movq %rbx, %rax 102 | movq %rdi, %rdx 103 | movq %r14, %rdi 104 | movq %r8, %r10 105 | movq %r9, %r8 106 | movq (%rbp), %r9 107 | add $0x08, %rbp 108 | syscall 109 | movq %rax, %rbx 110 | jmp * (%rbp) 111 | 112 | .global x86_64_linux_syscall_primop5 113 | x86_64_linux_syscall_primop5: 114 | movq %rbx, %rax 115 | movq %rdi, %rdx 116 | movq %r14, %rdi 117 | movq %r8, %r10 118 | movq %r9, %r8 119 | syscall 120 | movq %rax, %rbx 121 | jmp * (%rbp) 122 | 123 | .global x86_64_linux_syscall_primop4 124 | x86_64_linux_syscall_primop4: 125 | movq %rbx, %rax 126 | movq %rdi, %rdx 127 | movq %r14, %rdi 128 | movq %r8, %r10 129 | syscall 130 | movq %rax, %rbx 131 | jmp * (%rbp) 132 | 133 | .global x86_64_linux_syscall_primop3 134 | x86_64_linux_syscall_primop3: 135 | movq %rbx, %rax 136 | movq %rdi, %rdx 137 | movq %r14, %rdi 138 | syscall 139 | movq %rax, %rbx 140 | jmp * (%rbp) 141 | 142 | .global x86_64_linux_syscall_primop2 143 | x86_64_linux_syscall_primop2: 144 | movq %rbx, %rax 145 | movq %r14, %rdi 146 | syscall 147 | movq %rax, %rbx 148 | jmp * (%rbp) 149 | 150 | .global x86_64_linux_syscall_primop1 151 | x86_64_linux_syscall_primop1: 152 | movq %rbx, %rax 153 | movq %r14, %rdi 154 | syscall 155 | movq %rax, %rbx 156 | jmp * (%rbp) 157 | 158 | .global x86_64_linux_syscall_primop0 159 | x86_64_linux_syscall_primop0: 160 | movq %rbx, %rax 161 | syscall 162 | movq %rax, %rbx 163 | jmp * (%rbp) 164 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Arch/X86_64/cpuid.c: -------------------------------------------------------------------------------- 1 | /********************************************************** 2 | * Convertion between GHC STG calling convention on x86-64 3 | * and CPUID instruction 4 | * ******************************************************** 5 | * 6 | * STG: 7 | * Virtual registers: Base, Sp, Hp, R1-R6, SpLim 8 | * Registers: r13, rbp, r12, rbx, r14, rsi, rdi, r8, r9, r15 9 | * Use tail-call (jump) to Sp[0] to exit a function, so the 10 | * "return value" is to be stored in rbx (and following if we 11 | * want to return a tuple) 12 | * 13 | * CPUID: 14 | * Parameter EAX 15 | * Results: EAX, EBX, EDX, ECX 16 | * 17 | */ 18 | void x86_64_cpuid_primop() { 19 | asm ( 20 | "movq %%rbx, %%rax\n\t" 21 | "cpuid\n\t" 22 | "movq %%rbx, %%r14\n\t" 23 | "movq %%rax, %%rbx\n\t" 24 | "movq %%rdx, %%rdi\n\t" 25 | "movq %%rcx, %%rsi\n\t" 26 | "jmp * (%%rbp)\n\t" 27 | ::: 28 | ); 29 | } 30 | 31 | /* CPUID with EAX and ECX as parameters */ 32 | void x86_64_cpuid2_primop() { 33 | asm ( 34 | "movq %%rbx, %%rax\n\t" 35 | "movq %%r14, %%rcx\n\t" 36 | "cpuid\n\t" 37 | "movq %%rbx, %%r14\n\t" 38 | "movq %%rax, %%rbx\n\t" 39 | "movq %%rdx, %%rdi\n\t" 40 | "movq %%rcx, %%rsi\n\t" 41 | "jmp * (%%rbp)\n\t" 42 | ::: 43 | ); 44 | } 45 | 46 | /************************************************* 47 | * Convertion between x86-64 calling convention 48 | * and CPUID instruction 49 | * *********************************************** 50 | * 51 | * x86-64: 52 | * Parameters: rdi, rsi, rdx, rcx, r8, r9 53 | * Values returned: rax, rdx 54 | * Caller-save: rax, rdi, rsi, rdx, rcx, r8, r9, r10, r11 55 | * Callee-save: rbx, rsp, rbp, r12, r13, r14, r15 56 | * 57 | * CPUID: 58 | * Parameter EAX 59 | * Results: EAX, EBX, EDX, ECX 60 | */ 61 | void x86_64_cpuid_ffi() { 62 | asm ( 63 | "movq %%rdi, %%rax\n\t" 64 | "movq %%rbx, %%r8\n\t" //save RBX 65 | "cpuid\n\t" 66 | "mov %%eax, (%%rsi)\n\t" 67 | "mov %%ebx, 0x04(%%rsi)\n\t" 68 | "mov %%edx, 0x0c(%%rsi)\n\t" 69 | "mov %%ecx, 0x08(%%rsi)\n\t" 70 | "movq %%r8, %%rbx\n\t" // restore RBX 71 | ::: 72 | ); 73 | } 74 | 75 | void x86_64_cpuid2_ffi() { 76 | asm ( 77 | "movq %%rdi, %%rax\n\t" 78 | "movq %%rbx, %%r8\n\t" //save RBX 79 | "movq %%rcx, %%r9\n\t" //save RCX 80 | "movq %%rsi, %%rcx\n\t" 81 | "cpuid\n\t" 82 | "mov %%eax, (%%rsi)\n\t" 83 | "mov %%ebx, 0x04(%%rsi)\n\t" 84 | "mov %%edx, 0x0c(%%rsi)\n\t" 85 | "mov %%ecx, 0x08(%%rsi)\n\t" 86 | "movq %%r8, %%rbx\n\t" // restore RBX 87 | "movq %%r9, %%rcx\n\t" // restore RBX 88 | ::: 89 | ); 90 | } 91 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Compression/Algorithms/LZ77.hs: -------------------------------------------------------------------------------- 1 | -- | Implementation of LZ77 2 | -- 3 | -- The idea is to use a sliding window to compress and decompress. The window w 4 | -- contains the n last tokens you have (de)compressed. It is initialized with a 5 | -- default element (ini :: a). The size of the window is a parameter. 6 | -- 7 | -- You have a sequence of tokens s :: [a] to compress. You seek for the longest 8 | -- proper prefix p of s that is present in (w ++ dropLast p). The recursive 9 | -- definition allows for multiple repetition of the same pattern. 10 | -- E.g. w = xxxxx102, s = 1021021023 -> p has length 9 and position (n-3) 11 | -- 12 | -- The maximum length of p is parametric. p can't be equal to s, it is a 13 | -- *proper* prefix, meaning that at least the last token of s is not in p. 14 | -- 15 | -- Each compression step returns a (Code pos len c :: Code a) where pos and len 16 | -- are respectively the position and length of the prefix in the window. "c" is 17 | -- the token just after the prefix in s. When len is 0, only one character 18 | -- of s is encoded. 19 | -- 20 | -- The final result is a sequence of (Code a). It can be later transformed into 21 | -- a new sequence of [a] by encoding positions and lengths into "a" values 22 | -- (e.g. imagine "a" is a byte (Word8)). 23 | -- 24 | -- The decompression algorithm is similar. It uses the same kind of window. It 25 | -- decompresses an input s :: [Code a] into a [a]. 26 | -- 27 | -- From the paper: 28 | -- "A Universal Algorithm for Sequential Data Compression" 29 | -- Ziv, Jacob; Lempel, Abraham (May 1977) 30 | -- IEEE Transactions on Information Theory 23 (3): 337–343 31 | module Haskus.Format.Compression.Algorithms.LZ77 32 | ( Code(..) 33 | , compress 34 | , decompress 35 | ) 36 | where 37 | 38 | import Data.Foldable (maximumBy) 39 | import Data.Ord (comparing) 40 | import Data.Sequence (Seq,viewl,ViewL(..),(|>),(><)) 41 | import qualified Data.Sequence as Seq 42 | 43 | -- | A code (prefix + single value) 44 | data Code a = Code 45 | { codePosition :: Int -- ^ Position of the prefix in the window 46 | , codeLength :: Int -- ^ Length of the prefix 47 | , codeElem :: a -- ^ Value after the prefix 48 | } deriving (Show) 49 | 50 | -- | Compress a sequence, using LZ77 51 | -- 52 | -- `ls` is the maximal word length 53 | -- `n` is the buffer length 54 | -- `ini` is the value filling the buffer initially 55 | compress :: (Eq a) => Int -> Int -> a -> [a] -> [Code a] 56 | compress ls n ini = rec (Seq.replicate (n-ls) ini) 57 | where 58 | -- return the length and the value of the longest prefix 59 | prefixLen :: Eq a => [a] -> Seq a -> Int 60 | prefixLen = prefixLen' 0 61 | 62 | prefixLen' len u v = case (u, viewl v) of 63 | (s:ss,b: prefixLen' (len+1) ss (bs |> s) 64 | _ -> len 65 | 66 | rec _ [] = [] 67 | rec b s = Code pos len k : rec newb ks 68 | where 69 | -- current word (max length = ls-1) of s 70 | w = take (ls-1) s 71 | 72 | -- prefix lengths and their position [(len,pos)] 73 | prefixes = fmap (prefixLen w) (Seq.tails b) `Seq.zip` Seq.fromList [0..Seq.length b] 74 | 75 | -- longest prefix length and its position 76 | (len,pos) = maximumBy (comparing fst) prefixes 77 | 78 | -- last char and remaining sequence 79 | (k:ks) = drop len s 80 | 81 | -- new buffer 82 | newb = Seq.drop (len+1) b >< Seq.fromList (take (len+1) s) 83 | 84 | 85 | -- | Decompress a sequence, using LZ77 86 | -- 87 | -- `ls` is the maximal word length 88 | -- `n` is the buffer length 89 | -- `ini` is the value filling the buffer initially 90 | decompress :: Int -> Int -> a -> [Code a] -> [a] 91 | decompress ls n ini = rec (replicate (n-ls) ini) 92 | where 93 | rec _ [] = [] 94 | rec b (Code pos len c:ss) = w ++ rec newb ss 95 | where 96 | b' = b ++ drop pos b' 97 | w = take len (drop pos b') ++ [c] 98 | newb = drop (len+1) b ++ w 99 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Compression/GZip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | 4 | -- | GZip compression 5 | module Haskus.Format.Compression.GZip 6 | ( Member(..) 7 | , Flag(..) 8 | , Flags 9 | , decompressGet 10 | , decompress 11 | ) 12 | where 13 | 14 | import Data.Foldable (toList) 15 | 16 | import qualified Haskus.Format.Compression.Algorithms.Deflate as D 17 | import Haskus.Format.Binary.Get as Get 18 | import Haskus.Format.Binary.Bits.Order 19 | import Haskus.Format.Binary.Buffer 20 | import Haskus.Format.Binary.Word 21 | import Haskus.Format.Binary.BitSet (BitSet,CBitSet) 22 | import qualified Haskus.Format.Binary.BitSet as BitSet 23 | import qualified Haskus.Format.Text as Text 24 | import Haskus.Format.Text (Text,getTextUtf8Nul,unpack) 25 | import Haskus.Format.Text (textFormat,hex,(%)) 26 | import Haskus.Utils.Flow (when) 27 | 28 | -- | Member file 29 | data Member = Member 30 | { memberFlags :: Flags 31 | , memberTime :: Word32 32 | , memberExtraFlags :: Word8 33 | , memberOS :: Word8 34 | , memberName :: Text 35 | , memberComment :: Text 36 | , memberContent :: Buffer 37 | , memberCRC :: Word16 38 | , memberCRC32 :: Word32 39 | , memberSize :: Word32 -- ^ uncompressed input size (module 1^32) 40 | } 41 | deriving (Show) 42 | 43 | 44 | -- | Decompress the members of the archive 45 | decompress :: Buffer -> [Member] 46 | decompress = runGetOrFail decompressGet 47 | 48 | -- | Decompress the members of the archive 49 | decompressGet :: Get [Member] 50 | decompressGet = rec [] 51 | where 52 | rec xs = Get.isEmpty >>= \case 53 | True -> return (reverse xs) 54 | False -> do 55 | x <- getMember 56 | rec (x:xs) 57 | 58 | 59 | -- | Get a member of the archive 60 | getMember :: Get Member 61 | getMember = do 62 | id1 <- getWord8 63 | id2 <- getWord8 64 | when (id1 /= 0x1f || id2 /= 0x8b) $ 65 | error $ unpack $ textFormat ("Invalid archive file: " % hex % " " % hex) id1 id2 66 | 67 | comp <- getWord8 68 | when (comp /= 8) $ 69 | error "Unknown compression method" 70 | 71 | flags <- BitSet.fromBits <$> getWord8 72 | mtime <- getWord32le -- modification time 73 | xfl <- getWord8 -- extra flags 74 | os <- getWord8 -- os 75 | 76 | when (BitSet.member flags FlagExtra) $ do 77 | xlen <- getWord16le 78 | skip (fromIntegral xlen) 79 | 80 | name <- if BitSet.member flags FlagName 81 | then getTextUtf8Nul 82 | else return Text.empty 83 | 84 | comment <- if BitSet.member flags FlagComment 85 | then getTextUtf8Nul 86 | else return Text.empty 87 | 88 | crc <- if BitSet.member flags FlagCRC 89 | then getWord16le 90 | else return 0 91 | 92 | getBitGet BB D.decompress $ \content -> do 93 | 94 | crc32 <- getWord32le 95 | isize <- getWord32le 96 | 97 | return $ Member flags mtime xfl os name comment 98 | (bufferPackByteList (toList content)) crc crc32 isize 99 | 100 | 101 | -- | Information flag 102 | data Flag 103 | = FlagText 104 | | FlagCRC 105 | | FlagExtra 106 | | FlagName 107 | | FlagComment 108 | deriving (Show,Eq,Enum,CBitSet) 109 | 110 | -- | Flags 111 | type Flags = BitSet Word8 Flag 112 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Elf/Move.hs: -------------------------------------------------------------------------------- 1 | -- | Move sections 2 | module Haskus.Format.Elf.Move 3 | ( MoveEntry (..) 4 | , getMoveEntry 5 | , putMoveEntry 6 | ) 7 | where 8 | 9 | import Haskus.Format.Binary.Bits 10 | import Haskus.Format.Binary.Word 11 | import Haskus.Format.Binary.Get 12 | import Haskus.Format.Binary.Put 13 | import Haskus.Format.Elf.PreHeader 14 | 15 | -- | Move record 16 | data MoveEntry = MoveEntry 17 | { moveValue :: Word64 -- ^ Symbol value 18 | , moveSymbolIndex :: Word64 -- ^ Index 19 | , moveSymbolSize :: Word8 -- ^ Size 20 | , moveOffset :: Word64 -- ^ Symbol offset 21 | , moveRepeatCount :: Word16 -- ^ Repeat count 22 | , moveStride :: Word16 -- ^ Stride info 23 | } 24 | deriving (Show,Eq) 25 | 26 | -- | Getter for a move entry 27 | getMoveEntry :: PreHeader -> Get MoveEntry 28 | getMoveEntry pre = do 29 | let (_,gw16,_,gw64,gwN) = getGetters pre 30 | 31 | value <- gw64 32 | info <- gwN 33 | 34 | MoveEntry 35 | value 36 | (info `shiftR` 8) 37 | (fromIntegral $ info .&. 0xff) 38 | <$> gwN 39 | <*> gw16 40 | <*> gw16 41 | 42 | -- | Putter for a move entry 43 | putMoveEntry :: PreHeader -> MoveEntry -> Put 44 | putMoveEntry pre e = do 45 | let 46 | (_,pw16,_,pw64,pwN) = getPutters pre 47 | info = (moveSymbolIndex e `shiftL` 8) 48 | .|. fromIntegral (moveSymbolSize e) 49 | 50 | pw64 (moveValue e) 51 | pwN info 52 | pwN (moveOffset e) 53 | pw16 (moveRepeatCount e) 54 | pw16 (moveStride e) 55 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Elf/Note.hs: -------------------------------------------------------------------------------- 1 | -- | Note sections 2 | module Haskus.Format.Elf.Note 3 | ( RawNote (..) 4 | , getRawNote 5 | , putRawNote 6 | ) 7 | where 8 | 9 | 10 | import Haskus.Format.Binary.Word 11 | import Haskus.Format.Binary.Get 12 | import Haskus.Format.Binary.Put 13 | import Haskus.Format.Elf.PreHeader 14 | 15 | -- | Note 16 | data RawNote = RawNote 17 | { rawnoteNameLength :: Word32 18 | , rawnoteDescriptorSize :: Word32 19 | , rawnoteType :: Word32 20 | } 21 | deriving (Show,Eq) 22 | 23 | -- | Getter for a note 24 | getRawNote :: PreHeader -> Get RawNote 25 | getRawNote pre = do 26 | let (_,_,gw32,_,_) = getGetters pre 27 | 28 | RawNote 29 | <$> gw32 30 | <*> gw32 31 | <*> gw32 32 | 33 | -- | Putter for a note 34 | putRawNote :: PreHeader -> RawNote -> Put 35 | putRawNote pre note = do 36 | let (_,_,pw32,_,_) = getPutters pre 37 | 38 | pw32 (rawnoteNameLength note) 39 | pw32 (rawnoteDescriptorSize note) 40 | pw32 (rawnoteType note) 41 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Elf/Relocation.hs: -------------------------------------------------------------------------------- 1 | -- | ELF relocations 2 | module Haskus.Format.Elf.Relocation 3 | ( RelocationEntry (..) 4 | , getRelocationEntry 5 | , putRelocationEntry 6 | ) 7 | where 8 | 9 | import Haskus.Format.Binary.Bits 10 | import Haskus.Format.Binary.Get 11 | import Haskus.Format.Binary.Put 12 | import Haskus.Format.Binary.Word 13 | import Haskus.Format.Elf.PreHeader 14 | import Haskus.Format.Elf.Header 15 | import Haskus.Format.Elf.RelocationType 16 | 17 | -- | Relocation entry 18 | data RelocationEntry = RelocationEntry 19 | { relocAddress :: Word64 20 | , relocType :: RelocationType 21 | , relocSymbolIndex :: Word32 22 | , relocAddend :: Maybe Int64 23 | } 24 | deriving (Show) 25 | 26 | -- | Getter for a relocation entry 27 | getRelocationEntry :: PreHeader -> Header -> Bool -> Get RelocationEntry 28 | getRelocationEntry i h withAddend = do 29 | let (_,_,_,_,gwN) = getGetters i 30 | 31 | addr <- gwN 32 | info <- gwN 33 | let 34 | typ = toRelocType (headerArch h) $ case preHeaderWordSize i of 35 | WordSize32 -> fromIntegral (info .&. 0xff) 36 | WordSize64 -> fromIntegral (info .&. 0xffffffff) 37 | 38 | sym = case preHeaderWordSize i of 39 | WordSize32 -> fromIntegral (info `shiftR` 8) 40 | WordSize64 -> fromIntegral (info `shiftR` 32) 41 | 42 | ad <- if withAddend 43 | then Just . fromIntegral <$> gwN 44 | else return Nothing 45 | 46 | return $ RelocationEntry addr typ sym ad 47 | 48 | -- | Putter for a relocation entry 49 | putRelocationEntry :: PreHeader -> Bool -> RelocationEntry -> Put 50 | putRelocationEntry i withAddend rel = do 51 | let 52 | (_,_,_,_,pwN) = getPutters i 53 | sym = relocSymbolIndex rel 54 | typ = fromRelocType (relocType rel) 55 | info = case preHeaderWordSize i of 56 | WordSize32 -> (fromIntegral sym `shiftL` 8) 57 | .|. (fromIntegral typ .&. 0xff) 58 | WordSize64 -> (fromIntegral sym `shiftL` 32) 59 | .|. (fromIntegral typ .&. 0xffffffff) 60 | 61 | pwN (relocAddress rel) 62 | pwN info 63 | case (withAddend, relocAddend rel) of 64 | (True, Just x) -> pwN (fromIntegral x) 65 | (False, Nothing) -> return () 66 | _ -> error "Addend not found" 67 | 68 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/String.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | -- | Various String formats (C string, etc.) 6 | module Haskus.Format.String 7 | ( CChar 8 | , FS.CString 9 | , withCString 10 | , withCStringLen 11 | , castCCharToChar 12 | , castCharToCChar 13 | , peekCStringLen 14 | , peekCString 15 | -- * Fixed-size CString buffer 16 | , CStringBuffer 17 | , fromCStringBuffer 18 | , toCStringBuffer 19 | , emptyCStringBuffer 20 | ) 21 | where 22 | 23 | import qualified Foreign.C.String as FS 24 | import Foreign.C.Types (CChar(..)) 25 | import Foreign.Ptr 26 | 27 | import Haskus.Format.Binary.Word 28 | import Haskus.Format.Binary.Storable 29 | import Haskus.Format.Binary.Vector as Vec 30 | import Haskus.Utils.Types 31 | import Haskus.Utils.Monad 32 | 33 | -- | Fixed-size buffer containing a CString 34 | newtype CStringBuffer (n :: Nat) 35 | = CStringBuffer (Vector n Int8) 36 | deriving (Storable) 37 | 38 | instance KnownNat n => Show (CStringBuffer n) where 39 | show = show . fromCStringBuffer 40 | 41 | -- | Convert a CChar into a Char 42 | castCCharToChar :: CChar -> Char 43 | castCCharToChar = FS.castCCharToChar 44 | 45 | -- | Convert a Char into a CChar 46 | castCharToCChar :: Char -> CChar 47 | castCharToCChar = FS.castCharToCChar 48 | 49 | -- | Peek a CString whose size is known 50 | peekCStringLen :: MonadIO m => Word -> Ptr CChar -> m String 51 | peekCStringLen len p = liftIO (FS.peekCStringLen (p, fromIntegral len)) 52 | 53 | -- | Peek a CString 54 | peekCString :: MonadIO m => Ptr CChar -> m String 55 | peekCString = liftIO . FS.peekCString 56 | 57 | -- | Convert a \0-terminal vector into a string 58 | fromCStringBuffer :: (KnownNat n) => CStringBuffer (n :: Nat) -> String 59 | fromCStringBuffer (CStringBuffer v) = fmap (castCCharToChar . CChar) . takeWhile (/= 0) . Vec.toList $ v 60 | 61 | -- | Convert from a String into a \0-terminal vector 62 | toCStringBuffer :: (KnownNat n) => String -> CStringBuffer (n :: Nat) 63 | toCStringBuffer s = CStringBuffer (Vec.fromFilledListZ 0 . fmap (f . castCharToCChar) $ s) 64 | where 65 | f (CChar x) = x 66 | 67 | -- | Empty string 68 | emptyCStringBuffer :: (KnownNat n) => CStringBuffer (n :: Nat) 69 | emptyCStringBuffer = CStringBuffer (Vec.replicate 0) 70 | 71 | -- | Use a String a a null-terminated string 72 | withCString :: MonadInIO m => String -> (Ptr CChar -> m a) -> m a 73 | withCString s = liftWith (FS.withCString s) 74 | 75 | -- | Use a String a a null-terminated string 76 | withCStringLen :: MonadInIO m => String -> (Ptr CChar -> Word -> m a) -> m a 77 | withCStringLen s f = liftWith (FS.withCStringLen s) f' 78 | where 79 | f' (p, n) = f p (fromIntegral n) 80 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/Format/Text.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Format.Text 2 | ( module Data.Text 3 | -- * Conversions 4 | , bufferDecodeUtf8 5 | , textEncodeUtf8 6 | , stringEncodeUtf8 7 | -- * Formatting 8 | , textFormat 9 | , F.Format 10 | , (F.%) 11 | , (F.%.) 12 | , module Formatting.Formatters 13 | -- * Parsing 14 | , textParseHexadecimal 15 | -- * Get/Put 16 | , putTextUtf8 17 | , getTextUtf8 18 | , getTextUtf8Nul 19 | -- * IO 20 | , T.putStrLn 21 | ) 22 | where 23 | 24 | import Data.Text hiding (center) 25 | import qualified Data.Text.Encoding as T 26 | import qualified Data.Text as T 27 | import qualified Data.Text.IO as T 28 | import Formatting as F 29 | import Formatting.Formatters 30 | import Data.Text.Read as T 31 | 32 | import Haskus.Format.Binary.Buffer 33 | import Haskus.Format.Binary.Put 34 | import Haskus.Format.Binary.Get 35 | 36 | -- | Decode Utf8 37 | bufferDecodeUtf8 :: Buffer -> Text 38 | bufferDecodeUtf8 (Buffer bs) = T.decodeUtf8 bs 39 | 40 | -- | Encode Text into Utf8 41 | textEncodeUtf8 :: Text -> Buffer 42 | textEncodeUtf8 = Buffer . T.encodeUtf8 43 | 44 | -- | Encode String into Utf8 45 | stringEncodeUtf8 :: String -> Buffer 46 | stringEncodeUtf8 = textEncodeUtf8 . T.pack 47 | 48 | -- | Format a text (strict) 49 | textFormat :: Format Text a -> a 50 | textFormat = F.sformat 51 | 52 | -- | Parse an hexadecimal number 53 | -- FIXME: use a real parser (MegaParsec, etc.) 54 | textParseHexadecimal :: Integral a => Text -> Either String a 55 | textParseHexadecimal s = fst <$> T.hexadecimal s 56 | 57 | -- | Put an UTF8 encoded text 58 | putTextUtf8 :: Text -> Put 59 | putTextUtf8 = putBuffer . textEncodeUtf8 60 | 61 | -- | Pull n bytes from the input, as a Buffer 62 | getTextUtf8 :: Word -> Get Text 63 | getTextUtf8 sz = bufferDecodeUtf8 <$> getBuffer sz 64 | 65 | -- | Pull \0 terminal text 66 | getTextUtf8Nul :: Get Text 67 | getTextUtf8Nul = bufferDecodeUtf8 <$> getBufferNul 68 | 69 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System.hs: -------------------------------------------------------------------------------- 1 | -- | System programming 2 | -- 3 | -- This module reexport other modules and functions useful for system 4 | -- programming with Haskus. 5 | module Haskus.System 6 | ( module Haskus.System.Devices 7 | , module Haskus.System.Event 8 | , module Haskus.System.Graphics 9 | , module Haskus.System.Input 10 | , module Haskus.System.Process 11 | , module Haskus.System.Sys 12 | , module Haskus.System.System 13 | , module Haskus.System.Terminal 14 | , module Haskus.System.Power 15 | , module Haskus.System.FileSystem 16 | , module Haskus.Utils.Flow 17 | ) 18 | where 19 | 20 | import Haskus.System.Devices 21 | import Haskus.System.Event 22 | import Haskus.System.Graphics 23 | import Haskus.System.Input hiding (V) 24 | import Haskus.System.Process 25 | import Haskus.System.Sys 26 | import Haskus.System.System 27 | import Haskus.System.Terminal 28 | import Haskus.System.Power 29 | import Haskus.System.FileSystem 30 | import Haskus.Utils.Flow 31 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | -- | Event management 6 | module Haskus.System.Event 7 | ( newEventReader 8 | , onEvent 9 | , onEventWithData 10 | ) 11 | where 12 | 13 | import Prelude hiding (init,tail) 14 | 15 | import Haskus.System.Linux.Handle 16 | import Haskus.System.Linux.FileSystem.ReadWrite 17 | import Haskus.Utils.Flow 18 | import Haskus.Utils.STM 19 | import Haskus.System.Sys 20 | import Haskus.System.Process 21 | import Foreign.Ptr 22 | import Haskus.Format.Binary.Storable 23 | 24 | -- | Create a new thread reading events and putting them in a TChan 25 | newEventReader :: forall a. Storable a => Handle -> Sys (TChan a) 26 | newEventReader h = do 27 | let 28 | sz = sizeOfT @a 29 | nb = 50 -- number of events read at once 30 | 31 | ch <- newBroadcastTChanIO 32 | sysFork "Event reader" <| allocaArray nb <| \ptr -> forever <| runE <| do 33 | threadWaitRead h 34 | sz2 <- sysRead h (castPtr ptr) (fromIntegral sz * fromIntegral nb) 35 | -- FIXME: we should somehow signal if an error occured 36 | evs <- peekArray (fromIntegral sz2 `div` fromIntegral sz) ptr 37 | atomically (mapM_ (writeTChan ch) evs) 38 | return ch 39 | 40 | -- | Read events in the given channel forever 41 | onEvent :: TChan e -> (e -> Sys ()) -> Sys () 42 | onEvent bch f = onEventWithData () bch (const f) 43 | 44 | -- | Read events in the given channel forever, pass a user-defined data 45 | onEventWithData :: a -> TChan e -> (a -> e -> Sys a) -> Sys () 46 | onEventWithData x bch f = do 47 | sysLog LogInfo "Creating event listener" 48 | 49 | ch <- atomically $ dupTChan bch 50 | sysFork "TChan event listener" $ do 51 | let 52 | go a = do 53 | e <- atomically (readTChan ch) 54 | a' <- f a e 55 | go a' 56 | go x 57 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/EventLoop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -- | Event loop 4 | module Haskus.System.EventLoop 5 | ( L 6 | , JobResponse (..) 7 | , mainLoop 8 | ) 9 | where 10 | 11 | import Control.Concurrent.STM 12 | import Haskus.Utils.Flow 13 | 14 | -- Note [Event loop] 15 | -- ~~~~~~~~~~~~~~~~~ 16 | -- 17 | -- The event loop is loosely based on the EFL's main loop (Enlightenment 18 | -- Foundation Libraries). 19 | -- 20 | -- /------->-------\ 21 | -- | | 22 | -- | | 23 | -- | PreIdle jobs 24 | -- | | 25 | -- | |<-----------<-----------\ Execute idle jobs or sleep 26 | -- | Idle jobs (optional) or sleep | until an event occurs 27 | -- ^ |------------>-----------/ 28 | -- | | 29 | -- | PostIdle jobs 30 | -- | | 31 | -- | |<-----------<-----------\ 32 | -- | Event handlers | Handle all queued events 33 | -- | |------------>-----------/ 34 | -- | | 35 | -- \-------<-------/ 36 | -- 37 | -- Events happen asynchronously but their handlers are executed sequentially 38 | -- (i.e., without concurrency) in the event arrival order. We can use these 39 | -- handlers to modify a state without having to deal with race conditions or 40 | -- scheduling (fairness, etc.). 41 | -- 42 | -- As a consequence, jobs executed in the event loop must be as short as 43 | -- possible. They mustn't block or wait for events themselves. These jobs are 44 | -- executed by a single thread (no concurrence): longer jobs must be explicitly 45 | -- threaded. 46 | -- 47 | -- 48 | -- 49 | -- Note [Rendering loop] 50 | -- ~~~~~~~~~~~~~~~~~~~~~ 51 | -- 52 | -- The rendering loop manages the GUI. It is an event loop where events can be 53 | -- generated by input devices, timers, animators, etc. 54 | -- 55 | -- The GUI state is altered in event handlers (and maybe in some idle jobs). 56 | -- 57 | -- The rendering itself is performed by a PredIdle job. 58 | 59 | 60 | type L a = IO a 61 | 62 | data JobResponse 63 | = JobRenew 64 | | JobRemove 65 | deriving (Show,Eq) 66 | 67 | mainLoop :: TVar [L JobResponse] -> TQueue (L JobResponse) -> TVar [L JobResponse] -> TQueue (L ()) -> L () 68 | mainLoop enterers idlers exiters handlers = go 69 | 70 | where 71 | go = do 72 | execJobs enterers 73 | execIdle 74 | execJobs exiters 75 | execHandlers handlerLimit 76 | go 77 | 78 | -- if handlers appear faster than they are executed, we still want to 79 | -- execute the loop sometimes. We use this limit to ensure that we don't 80 | -- execute more than `handlerLimit` handlers in one iteration. 81 | handlerLimit :: Int 82 | handlerLimit = 1000 83 | 84 | execJobs jobList = do 85 | jobs <- atomically <| swapTVar jobList [] 86 | res <- sequence jobs 87 | -- filter jobs that shouldn't be executed anymore 88 | let jobs' = (jobs `zip` res) 89 | |> filter ((== JobRenew) . snd) 90 | |> fmap fst 91 | -- append the renewed jobs to the jobs that may have been added since 92 | -- we started executing jobs 93 | atomically <| modifyTVar' jobList (jobs'++) 94 | 95 | -- execute idle jobs or sleep 96 | execIdle = do 97 | r <- atomically <| do 98 | emptyHandler <- isEmptyTQueue handlers 99 | emptyIdler <- isEmptyTQueue idlers 100 | case (emptyHandler, emptyIdler) of 101 | (True,True) -> retry -- sleep 102 | (True,False) -> tryReadTQueue idlers -- return idle job 103 | (False,_) -> return Nothing 104 | case r of 105 | Nothing -> return () 106 | Just j -> do 107 | -- execute idle job 108 | j >>= \case 109 | -- queue it again if necessary 110 | JobRenew -> atomically (writeTQueue idlers j) 111 | JobRemove -> return () 112 | -- loop 113 | execIdle 114 | 115 | -- execute handlers 116 | execHandlers 0 = return () 117 | execHandlers limit = do 118 | mj <- atomically <| tryReadTQueue handlers 119 | case mj of 120 | Nothing -> return () 121 | Just j -> do 122 | j 123 | execHandlers (limit - 1) 124 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/FileSystem.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -freduction-depth=0 #-} 2 | 3 | module Haskus.System.FileSystem 4 | ( withOpenAt 5 | , atomicReadBuffer 6 | , readBuffer 7 | , readStorable 8 | , HandleFlag(..) 9 | , FilePermission(..) 10 | ) 11 | where 12 | 13 | 14 | import Haskus.System.Linux.Handle 15 | import Haskus.System.Linux.FileSystem 16 | import Haskus.System.Linux.FileSystem.ReadWrite 17 | import Haskus.Format.Binary.Buffer 18 | import Haskus.Format.Binary.Word 19 | import Haskus.Format.Binary.Storable 20 | import Haskus.Format.Binary.BitSet as BitSet 21 | import Haskus.System.Sys 22 | import Haskus.Utils.Flow 23 | import Haskus.Utils.Types.List 24 | import Haskus.Format.Text 25 | 26 | -- | Open at 27 | withOpenAt :: forall xs zs m a. 28 | ( LiftVariant OpenErrors zs 29 | , LiftVariant xs zs 30 | , zs ~ Union xs OpenErrors 31 | , MonadInIO m 32 | ) => Handle -> FilePath -> HandleFlags -> FilePermissions -> (Handle -> Excepts xs m a) -> Excepts zs m a 33 | withOpenAt fd path flags perm act = do 34 | fd2 <- liftE (open (Just fd) path flags perm) 35 | liftE (act fd2) `finallyE` runE_ (close fd2) 36 | 37 | -- | Read a file with a single "read" 38 | -- 39 | -- Some files (e.g., in procfs) need to be read atomically to ensure that their 40 | -- contents is valid. In this function, we increase the buffer size until we can 41 | -- read the whole file in it with a single "read" call. 42 | atomicReadBuffer :: Handle -> FilePath -> Excepts (Union ReadErrors' OpenErrors) Sys Buffer 43 | atomicReadBuffer hdl path = withOpenAt hdl path BitSet.empty BitSet.empty (go 2000) 44 | where 45 | go :: Word64 -> Handle -> Excepts ReadErrors' Sys Buffer 46 | go sz fd = do 47 | -- use 0 offset to read from the beginning 48 | buf <- handleReadBuffer fd (Just 0) sz 49 | `onE` (\err -> do 50 | let msg = textFormat ("Atomic read file (failed with " % shown % ")") err 51 | sysLog LogWarning msg) 52 | 53 | if fromIntegral (bufferSize buf) == sz 54 | then go (sz*2) fd 55 | else return buf 56 | 57 | 58 | -- | Read into a buffer 59 | readBuffer :: Handle -> Maybe Word64 -> Word64 -> Excepts ReadErrors' Sys Buffer 60 | readBuffer hdl moffset size = handleReadBuffer hdl moffset size 61 | 62 | -- | Read a storable 63 | readStorable :: forall a. Storable a => Handle -> Maybe Word64 -> Excepts ReadErrors' Sys a 64 | readStorable hdl moffset = readBuffer hdl moffset (sizeOfT' @a) 65 | ||> bufferPeekStorable 66 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Graphics/Colour.hs: -------------------------------------------------------------------------------- 1 | -- | Colours 2 | module Haskus.System.Graphics.Colour 3 | ( module Data.Colour.Names 4 | , module Data.Colour 5 | ) 6 | where 7 | 8 | import Data.Colour.Names 9 | import Data.Colour 10 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Graphics/Config.hs: -------------------------------------------------------------------------------- 1 | -- | Mode-setting configuration 2 | module Haskus.System.Graphics.Config 3 | ( Config (..) 4 | , ConfigError 5 | , setConfig 6 | ) 7 | where 8 | 9 | import Haskus.System.Linux.Graphics.Entities 10 | import Haskus.System.Linux.Graphics.Property 11 | import Haskus.System.Linux.Graphics.Mode 12 | import Haskus.System.Linux.Graphics.Object 13 | import Haskus.System.Linux.Graphics.State 14 | import Haskus.System.Graphics 15 | import Haskus.Utils.Flow 16 | 17 | -- | This datatype represents a declarative mode-setting configuration. 18 | -- It indicates which entities should be connected to which other entities, 19 | -- which properties to set, etc. 20 | -- Then we can use this to perform mode-setting (either with the legacy non-atomic 21 | -- interface or with the atomic interface). We can also use it to check that the 22 | -- configuration is valid. 23 | -- 24 | -- This config is only used to perform mode-setting. It doesn't allocate 25 | -- any resource (FrameSource, PixelSource, Buffer, etc.). This is left for a 26 | -- calling function which would allocate these resources beforehand. The calling 27 | -- function can choose to allocate accelerated buffers or not, etc. 28 | data Config = Config 29 | { configController :: [( ControllerID 30 | , Maybe Mode 31 | , [ConnectorID] 32 | )] -- ^ Controller config 33 | , configPlane :: [( PlaneID 34 | , Maybe 35 | ( ControllerID 36 | , FrameSourceID 37 | , SrcRect 38 | , DestRect 39 | ) 40 | )] -- ^ Plane config 41 | , configProperties :: [( ObjectID 42 | , ObjectType 43 | , PropID 44 | , PropValue 45 | )] -- ^ Set properties 46 | } 47 | 48 | ------------------------------------------------------------------------------- 49 | -- Generic config 50 | ------------------------------------------------------------------------------- 51 | 52 | type ConfigError = () 53 | 54 | -- | Apply the given config 55 | setConfig :: GraphicCard -> Config -> IO ConfigError 56 | setConfig card config = do 57 | -- TODO: support atomic config 58 | let isAtomicSupported _ = False 59 | 60 | if isAtomicSupported card 61 | then setConfigAtomic card config 62 | else setConfigLegacy card config 63 | 64 | ------------------------------------------------------------------------------- 65 | -- Legacy config 66 | ------------------------------------------------------------------------------- 67 | 68 | -- | Apply the given config with the legacy interface 69 | setConfigLegacy :: GraphicCard -> Config -> IO ConfigError 70 | setConfigLegacy card config = do 71 | let hdl = graphicCardHandle card 72 | 73 | -- FIXME: we should perform error checking and report errors to the caller 74 | 75 | ---------------------------------------------------------------------- 76 | -- disconnect entities being modified.... 77 | ---------------------------------------------------------------------- 78 | 79 | -- disable planes 80 | forM_ (configPlane config) <| \(pid,_) -> 81 | runE_ <| setPlane hdl pid Nothing 82 | 83 | ---------------------------------------------------------------------- 84 | -- ...and then reconnect them in order and set properties 85 | ---------------------------------------------------------------------- 86 | 87 | -- configure controllers 88 | forM_ (configController config) <| \(cid,mmode,conns) -> 89 | case (mmode,conns) of 90 | (Nothing,[]) -> return () -- nothing to do 91 | _ -> runE_ <| setController' hdl cid Nothing conns mmode 92 | 93 | -- attach planes 94 | forM_ (configPlane config) <| \(pid,mopts) -> 95 | case mopts of 96 | Nothing -> return () -- nothing to do 97 | _ -> runE_ <| setPlane hdl pid mopts 98 | 99 | -- set properties 100 | forM_ (configProperties config) <| \(oid,otype,propid,val) -> 101 | runE_ <| setObjectProperty' hdl oid otype propid val 102 | 103 | ------------------------------------------------------------------------------- 104 | -- Atomic config 105 | ------------------------------------------------------------------------------- 106 | 107 | -- | Apply the given config with the atomic interface 108 | setConfigAtomic :: GraphicCard -> Config -> IO ConfigError 109 | setConfigAtomic _card _config = undefined 110 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Graphics/Diagrams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Diagrams utilities (specialized for the rasterific backend) 4 | module Haskus.System.Graphics.Diagrams 5 | ( rasterizeDiagram 6 | , VDiagram 7 | , VDiagram' 8 | , module Diagrams 9 | , module Diagrams.Prelude 10 | , text' 11 | , text 12 | ) 13 | where 14 | 15 | -- TODO 16 | -- We might use Diagrams queries to handle mouse clicks, etc. 17 | -- http://projects.haskell.org/diagrams/blog/2015-04-30-GTK-coordinates.html 18 | 19 | import Data.Typeable 20 | import Diagrams.Prelude hiding ((|>),(<|),text) 21 | import Diagrams hiding (text) 22 | import Diagrams.TwoD.Text (FontSlant(..),FontWeight(..),Text(..)) 23 | import Diagrams.Backend.Rasterific 24 | import Codec.Picture.Types 25 | import Data.Monoid (Any) 26 | 27 | type VDiagram' n = QDiagram Rasterific V2 n Any 28 | type VDiagram = QDiagram Rasterific V2 Float Any 29 | 30 | -- | Render a diagram into an image that can be displayed on a framebuffer 31 | rasterizeDiagram :: (RealFloat n, Typeable n) => SizeSpec V2 n -> VDiagram' n -> Image PixelRGBA8 32 | rasterizeDiagram spec = renderDia Rasterific (RasterificOptions spec) 33 | 34 | -- | Create a primitive text diagram from the given FontSlant, FontWeight, and 35 | -- string, with baseline alignment, envelope and trace based on the BoundingBox 36 | -- of the text. 37 | text' :: (RealFloat n, Typeable n, Renderable (Text n) b) => FontSlant -> FontWeight -> String -> QDiagram b V2 n Any 38 | text' = texterific' 39 | 40 | 41 | -- | Create a primitive text diagram from the given string, with baseline 42 | -- alignment, envelope and trace based on the BoundingBox of the text. 43 | text :: (RealFloat n, Typeable n, Renderable (Text n) b) => String -> QDiagram b V2 n Any 44 | text = texterific 45 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/ErrorCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Management of returned values from syscalls 6 | module Haskus.System.Linux.ErrorCode 7 | ( ErrorCode (..) 8 | , unhdlErr 9 | , checkErrorCode 10 | , checkErrorCode_ 11 | ) 12 | where 13 | 14 | import Haskus.Format.Binary.Word 15 | import Haskus.Format.Binary.Enum 16 | import Haskus.Utils.Flow 17 | import Haskus.System.Linux.Internals.Error 18 | 19 | -- | Error to call when a syscall returns an unexpected error value 20 | unhdlErr :: Show err => String -> err -> a 21 | unhdlErr str err = 22 | error ("Unhandled error "++ show err ++" returned by \""++str++"\". Report this as a haskus-system bug.") 23 | 24 | -- | Convert negative values into error codes 25 | checkErrorCode :: Monad m => Int64 -> Excepts '[ErrorCode] m Int64 26 | {-# INLINABLE checkErrorCode #-} 27 | checkErrorCode r 28 | | r < 0 = failureE (toCEnum (abs r)) 29 | | otherwise = pure r 30 | 31 | -- | Convert negative values into error codes, return () otherwise 32 | checkErrorCode_ :: Monad m => Int64 -> Excepts '[ErrorCode] m () 33 | {-# INLINABLE checkErrorCode_ #-} 34 | checkErrorCode_ r 35 | | r < 0 = failureE (toCEnum (abs r)) 36 | | otherwise = pure () 37 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/EventPoll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | Event polling 5 | module Haskus.System.Linux.EventPoll 6 | ( EventPollFlag(..) 7 | , sysEventPollCreate 8 | ) 9 | where 10 | 11 | import Haskus.System.Linux.ErrorCode 12 | import Haskus.System.Linux.Syscalls 13 | import Haskus.System.Linux.Handle 14 | import Haskus.Format.Binary.Word (Word64) 15 | import Haskus.Format.Binary.Bits ((.|.)) 16 | import Haskus.Utils.List (foldl') 17 | import Haskus.Utils.Flow 18 | 19 | -- | Polling flag 20 | data EventPollFlag 21 | = EventPollCloseOnExec 22 | deriving (Show,Eq) 23 | 24 | fromFlag :: EventPollFlag -> Word64 25 | fromFlag EventPollCloseOnExec = 0x80000 26 | 27 | fromFlags :: [EventPollFlag] -> Word64 28 | fromFlags = foldl' (.|.) 0 . fmap fromFlag 29 | 30 | -- | Create event poller 31 | sysEventPollCreate :: MonadIO m => [EventPollFlag] -> Excepts '[ErrorCode] m Handle 32 | sysEventPollCreate flags = do 33 | n <- checkErrorCode =<< liftIO (syscall_epoll_create1 (fromFlags flags)) 34 | return (Handle (fromIntegral n)) 35 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/FileSystem/Mount.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Filesystem mount 6 | module Haskus.System.Linux.FileSystem.Mount 7 | ( MountFlag(..) 8 | , MountFlags 9 | , UnmountFlag(..) 10 | , UnmountFlags 11 | , sysMount 12 | , sysUnmount 13 | , mountSysFS 14 | , mountDevFS 15 | , mountProcFS 16 | , mountTmpFS 17 | ) 18 | where 19 | 20 | import Foreign.Ptr (Ptr,nullPtr) 21 | import Haskus.Format.Binary.Word 22 | import Haskus.Format.Binary.BitSet 23 | import Haskus.Format.String (withCString) 24 | import qualified Haskus.Format.Binary.BitSet as BitSet 25 | import Haskus.System.Linux.ErrorCode 26 | import Haskus.System.Linux.Syscalls 27 | import Haskus.System.Linux.Internals.FileSystem 28 | import Haskus.Utils.Flow 29 | 30 | -- | Unmount flag 31 | data UnmountFlag 32 | = UnmountForce -- ^ Force unmounting 33 | | UnmountDetach -- ^ Just detach from the tree 34 | | UnmountExpire -- ^ Mark for expiry 35 | | UnmountDontFollow -- ^ Don't follow symlink on unmount 36 | deriving (Show,Eq,Enum,CBitSet) 37 | 38 | -- | Unmount flags 39 | type UnmountFlags = BitSet Word64 UnmountFlag 40 | 41 | -- | Mount a file system 42 | sysMount :: MonadInIO m => String -> String -> String -> MountFlags -> Ptr () -> Excepts '[ErrorCode] m () 43 | sysMount source target fstype flags dat = 44 | withCString source $ \source' -> 45 | withCString target $ \target' -> 46 | withCString fstype $ \fstype' -> 47 | liftIO (syscall_mount source' target' fstype' (BitSet.toBits flags) dat) 48 | >>= checkErrorCode_ 49 | 50 | 51 | -- | Unmount a file system 52 | sysUnmount :: MonadInIO m => String -> UnmountFlags -> Excepts '[ErrorCode] m () 53 | sysUnmount target flags = 54 | withCString target $ \target' -> 55 | liftIO (syscall_umount2 target' (BitSet.toBits flags)) 56 | >>= checkErrorCode_ 57 | 58 | -- | Type of the low-level Linux "mount" function 59 | type MountCall m = String -> String -> String -> MountFlags -> Ptr () -> Excepts '[ErrorCode] m () 60 | 61 | -- | Mount SysFS at the given location 62 | mountSysFS :: MonadIO m => MountCall m -> FilePath -> Excepts '[ErrorCode] m () 63 | mountSysFS mount path = mount "none" path "sysfs" BitSet.empty nullPtr 64 | 65 | -- | Mount DevFS at the given location 66 | mountDevFS :: MonadIO m => MountCall m -> FilePath -> Excepts '[ErrorCode] m () 67 | mountDevFS mount path = mount "none" path "devtmpfs" BitSet.empty nullPtr 68 | 69 | -- | Mount ProcFS at the given location 70 | mountProcFS :: MonadIO m => MountCall m -> FilePath -> Excepts '[ErrorCode] m () 71 | mountProcFS mount path = mount "none" path "proc" BitSet.empty nullPtr 72 | 73 | -- | Mount TmpFS at the given location 74 | mountTmpFS :: MonadIO m => MountCall m -> FilePath -> Excepts '[ErrorCode] m () 75 | mountTmpFS mount path = mount "none" path "tmpfs" BitSet.empty nullPtr 76 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/FileSystem/Notification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | -- | Notifications on file system (poll, select, inotify, etc.) 8 | module Haskus.System.Linux.FileSystem.Notification 9 | ( PollEvent(..) 10 | , PollEventSet 11 | , PollEntry(..) 12 | , PollResult(..) 13 | , sysPoll 14 | ) 15 | where 16 | 17 | import Haskus.Utils.Maybe (mapMaybe) 18 | import Haskus.Utils.Types.Generics (Generic) 19 | import Haskus.Utils.Flow 20 | import Haskus.Format.Binary.Word 21 | import Haskus.Format.Binary.Storable 22 | import Foreign.Ptr 23 | import Haskus.Format.Binary.BitSet (CBitSet, BitSet, fromBits, toBits) 24 | import Haskus.System.Linux.ErrorCode 25 | import Haskus.System.Linux.Handle 26 | import Haskus.System.Linux.Syscalls 27 | 28 | -- | Poll struct 29 | data PollStruct = PollStruct 30 | { pollFD :: Int32 31 | , pollEvents :: Word16 32 | , pollReturnedEvents :: Word16 33 | } deriving (Generic,Storable) 34 | 35 | -- | Polling event 36 | data PollEvent 37 | = PollReadable 38 | | PollWritable 39 | | PollPriorityReadable 40 | | PollError 41 | | PollHungUp 42 | | PollInvalidHandle 43 | | PollMessage 44 | | PollRemove 45 | | PollPeerHungUp 46 | | PollReadNormal 47 | | PollWriteNormal 48 | | PollReadBand 49 | | PollWriteBand 50 | deriving (Show,Eq,CBitSet) 51 | 52 | instance Enum PollEvent where 53 | fromEnum x = case x of 54 | PollReadable -> 0 55 | PollWritable -> 2 56 | PollPriorityReadable -> 1 57 | PollError -> 3 58 | PollHungUp -> 4 59 | PollInvalidHandle -> 5 60 | PollMessage -> 10 61 | PollRemove -> 12 62 | PollPeerHungUp -> 13 63 | PollReadNormal -> 6 64 | PollWriteNormal -> 8 65 | PollReadBand -> 7 66 | PollWriteBand -> 9 67 | toEnum x = case x of 68 | 0 -> PollReadable 69 | 2 -> PollWritable 70 | 1 -> PollPriorityReadable 71 | 3 -> PollError 72 | 4 -> PollHungUp 73 | 5 -> PollInvalidHandle 74 | 10 -> PollMessage 75 | 12 -> PollRemove 76 | 13 -> PollPeerHungUp 77 | 6 -> PollReadNormal 78 | 8 -> PollWriteNormal 79 | 7 -> PollReadBand 80 | 9 -> PollWriteBand 81 | _ -> error "Unknown poll event" 82 | 83 | -- | A set of polling events 84 | type PollEventSet = BitSet Word16 PollEvent 85 | 86 | -- | A polling entry 87 | data PollEntry = PollEntry Handle PollEventSet deriving (Show,Eq) 88 | 89 | -- | Result of a call to poll 90 | data PollResult 91 | = PollTimeOut -- ^ Time out 92 | | PollEvents [PollEntry] -- ^ Events returned 93 | deriving (Show,Eq) 94 | 95 | -- | Poll a set of file descriptors 96 | -- 97 | -- Timeout in milliseconds 98 | sysPoll :: MonadInIO m => [PollEntry] -> Bool -> Maybe Int64 -> Excepts '[ErrorCode] m PollResult 99 | sysPoll entries blocking timeout = do 100 | 101 | let 102 | toPollStruct (PollEntry (Handle fd) evs) = PollStruct 103 | { pollFD = fromIntegral fd -- poll allows negative FDs to indicate that the entry must be skipped, we don't 104 | , pollEvents = toBits evs 105 | , pollReturnedEvents = 0 106 | } 107 | fromPollStruct (PollStruct fd _ evs) = 108 | if evs == 0 109 | then Nothing 110 | else Just $ PollEntry (Handle (fromIntegral fd)) (fromBits evs) 111 | fds = fmap toPollStruct entries 112 | nfds = fromIntegral (length fds) :: Word64 113 | timeout' = if not blocking 114 | then 0 115 | else case timeout of 116 | Nothing -> -1 -- infinite blocking 117 | Just x -> abs x 118 | 119 | withArray fds $ \fds' -> do 120 | liftIO (syscall_poll (castPtr fds') nfds timeout') 121 | >>= checkErrorCode 122 | >>= \case 123 | 0 -> return PollTimeOut 124 | _ -> do 125 | retfds <- peekArray (fromIntegral (length fds)) fds' 126 | return (PollEvents $ mapMaybe fromPollStruct retfds) 127 | 128 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/FileSystem/SymLink.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | -- | Symbolic links 9 | module Haskus.System.Linux.FileSystem.SymLink 10 | ( sysSymlink 11 | , ReadSymLinkErrors 12 | , readSymbolicLink 13 | ) 14 | where 15 | 16 | import Haskus.System.Linux.Error 17 | import Haskus.System.Linux.ErrorCode 18 | import Haskus.System.Linux.Handle 19 | import Haskus.System.Linux.Syscalls 20 | import Haskus.Format.String 21 | import Haskus.Format.Binary.Storable 22 | import Haskus.Utils.Flow 23 | 24 | type ReadSymLinkErrors 25 | = '[ NotAllowed 26 | , NotSymbolicLink 27 | , FileSystemIOError 28 | , SymbolicLinkLoop 29 | , TooLongPathName 30 | , FileNotFound 31 | , OutOfKernelMemory 32 | , InvalidPathComponent 33 | ] 34 | 35 | -- | Read the path in a symbolic link 36 | readSymbolicLink :: MonadInIO m => Maybe Handle -> FilePath -> Excepts ReadSymLinkErrors m String 37 | readSymbolicLink hdl path = do 38 | sysReadLinkAt hdl path 39 | `catchLiftLeft` \case 40 | EACCES -> throwE NotAllowed 41 | EINVAL -> throwE NotSymbolicLink 42 | EIO -> throwE FileSystemIOError 43 | ELOOP -> throwE SymbolicLinkLoop 44 | ENAMETOOLONG -> throwE TooLongPathName 45 | ENOENT -> throwE FileNotFound 46 | ENOMEM -> throwE OutOfKernelMemory 47 | ENOTDIR -> throwE InvalidPathComponent 48 | EBADF -> error "readSymbolicLink: invalid handle" 49 | -- EFAULT: shouldn't happen (or is a haskus-system bug) 50 | e -> unhdlErr "readSymbolicLink" e 51 | 52 | 53 | -- | Wrapper for readlinkat syscall 54 | sysReadLinkAt :: MonadInIO m => Maybe Handle -> FilePath -> Excepts '[ErrorCode] m String 55 | sysReadLinkAt hdl path = tryReadLinkAt 2048 56 | where 57 | -- if no handle is passed, we assume the path is absolute and we give a 58 | -- (-1) file descriptor which should be ignored. If the path is relative, 59 | -- hopefully we will get a EBADF error 60 | fd = case hdl of 61 | Just (Handle x) -> x 62 | Nothing -> maxBound 63 | 64 | -- allocate a buffer and try to readlinkat. 65 | tryReadLinkAt size = do 66 | mv <- allocaBytes size $ \ptr -> 67 | withCString path $ \path' -> do 68 | n <- checkErrorCode =<< liftIO (syscall_readlinkat fd path' ptr (fromIntegral size)) 69 | if fromIntegral n == size 70 | then return Nothing 71 | else Just <$> peekCStringLen (fromIntegral n) ptr 72 | case mv of 73 | Nothing -> tryReadLinkAt (2*size) -- retry with double buffer size 74 | Just v -> return v 75 | 76 | -- | Create a symbolic link 77 | sysSymlink :: MonadInIO m => FilePath -> FilePath -> Excepts '[ErrorCode] m () 78 | sysSymlink src dest = 79 | withCString src $ \src' -> 80 | withCString dest $ \dest' -> 81 | checkErrorCode_ =<< liftIO (syscall_symlink src' dest') 82 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Futex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | Futex (user-space mutex) 5 | module Haskus.System.Linux.Futex 6 | ( FutexOp(..) 7 | , sysFutex 8 | , futexWait 9 | , futexWake 10 | , futexRequeue 11 | , futexCompareRequeue 12 | ) 13 | where 14 | 15 | import Foreign.Ptr 16 | import Haskus.Format.Binary.Word 17 | import Haskus.System.Linux.ErrorCode 18 | import Haskus.System.Linux.Syscalls 19 | import Haskus.System.Linux.Time 20 | import Haskus.Memory.Utils 21 | import Haskus.Utils.Flow 22 | 23 | -- | Futex operation 24 | data FutexOp 25 | = FutexWait 26 | | FutexWake 27 | | FutexFD 28 | | FutexRequeue 29 | | FutexCmpRequeue 30 | deriving (Show,Enum) 31 | 32 | -- | All the Futex API uses this `futex` syscall 33 | sysFutex :: MonadIO m => Ptr Int64 -> FutexOp -> Int64 -> Ptr TimeSpec -> Ptr Int64 -> Int64 -> Excepts '[ErrorCode] m Int64 34 | sysFutex uaddr op val timeout uaddr2 val3 = 35 | checkErrorCode =<< liftIO (syscall_futex uaddr (fromEnum op) val (castPtr timeout) uaddr2 val3) 36 | 37 | -- | Atomically check that addr contains val and sleep until it is wakened up or until the timeout expires 38 | futexWait :: MonadInIO m => Ptr Int64 -> Int64 -> Maybe TimeSpec -> Excepts '[ErrorCode] m () 39 | futexWait addr val timeout = 40 | withMaybeOrNull timeout $ \timeout' -> 41 | void (sysFutex addr FutexWait val timeout' nullPtr 0) 42 | 43 | -- | Wake `count` processes waiting on the futex 44 | -- Return the number of processes woken up 45 | futexWake :: MonadIO m => Ptr Int64 -> Int64 -> Excepts '[ErrorCode] m Int64 46 | futexWake addr count = 47 | sysFutex addr FutexWake count nullPtr nullPtr 0 48 | 49 | 50 | -- | Wake `count` processes waiting on the first futex 51 | -- and requeue the other ones on the second futex. 52 | -- 53 | -- Return the number of processes woken up 54 | futexRequeue :: MonadIO m => Ptr Int64 -> Int64 -> Ptr Int64 -> Excepts '[ErrorCode] m Int64 55 | futexRequeue addr count addr2 = 56 | sysFutex addr FutexRequeue count nullPtr addr2 0 57 | 58 | -- | Atomically compare the first futex with `val, then 59 | -- wake `count` processes waiting on the first futex 60 | -- and requeue the other ones on the second futex. 61 | -- 62 | -- Return the number of processes woken up 63 | futexCompareRequeue :: MonadIO m => Ptr Int64 -> Int64 -> Int64 -> Ptr Int64 -> Excepts '[ErrorCode] m Int64 64 | futexCompareRequeue addr val count addr2 = 65 | sysFutex addr FutexCmpRequeue count nullPtr addr2 val 66 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/Capability.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- | Graphic card capabilities 4 | module Haskus.System.Linux.Graphics.Capability 5 | ( getCapability 6 | , supports 7 | , Capability (..) 8 | , ClientCapability (..) 9 | , setClientCapability 10 | ) 11 | where 12 | 13 | import Haskus.System.Linux.Internals.Graphics 14 | import Haskus.System.Linux.Handle 15 | import Haskus.System.Linux.ErrorCode 16 | import Haskus.Format.Binary.Enum 17 | import Haskus.Format.Binary.Word 18 | import Haskus.Utils.Flow 19 | 20 | -- | Get a capability 21 | getCapability :: MonadInIO m => Handle -> Capability -> Excepts '[ErrorCode] m Word64 22 | getCapability hdl cap = do 23 | let s = StructGetCap (toEnumField cap) 0 24 | ioctlGetCapabilities s hdl ||> gcValue 25 | 26 | -- | Indicate if a capability is supported 27 | supports :: MonadInIO m => Handle -> Capability -> Excepts '[ErrorCode] m Bool 28 | supports hdl cap = getCapability hdl cap ||> (/= 0) 29 | 30 | -- | Set a client capability 31 | setClientCapability :: MonadInIO m => Handle -> ClientCapability -> Bool -> Excepts '[ErrorCode] m () 32 | setClientCapability hdl cap b = do 33 | let 34 | v = if b then 1 else 0 35 | s = StructSetClientCap (toEnumField cap) v 36 | void (ioctlSetClientCapability s hdl) 37 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Graphics events 4 | module Haskus.System.Linux.Graphics.Event 5 | ( Event(..) 6 | , peekEvents 7 | , EventType (..) 8 | , DRMEvent (..) 9 | ) 10 | where 11 | 12 | import Haskus.Format.Binary.Word 13 | import Foreign.Ptr 14 | import Haskus.Format.Binary.Buffer 15 | import Haskus.Format.Binary.Storable 16 | import Haskus.System.Linux.Internals.Graphics 17 | import Haskus.Utils.Monad 18 | 19 | -- | Graphics events 20 | data Event 21 | = Event EventType DRMEvent -- ^ Builtin event 22 | | CustomEvent Word32 Buffer -- ^ Custom event 23 | deriving (Show) 24 | 25 | -- | Peek events 26 | peekEvents :: forall m. MonadIO m => Ptr () -> Word32 -> m [Event] 27 | peekEvents = go 28 | where 29 | go _ 0 = return [] 30 | go p r = do 31 | (ev,len) <- peekEvent p 32 | evs <- go (p `plusPtr` fromIntegral len) (r - len) 33 | return (ev:evs) 34 | 35 | peekEvent :: Ptr () -> m (Event,Word32) 36 | peekEvent ptr = do 37 | e <- peek (castPtr ptr) 38 | v <- case toEventType (eventType e) of 39 | Just t -> Event t <$> peek (castPtr ptr) 40 | Nothing -> CustomEvent (eventType e) <$> 41 | bufferPackPtr (fromIntegral (eventLength e) - 8) (castPtr ptr `plusPtr` 8) 42 | 43 | return (v,eventLength e) 44 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/FrameSource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | -- | Frame source 6 | module Haskus.System.Linux.Graphics.FrameSource 7 | ( -- * Frame source 8 | FrameSource(..) 9 | , addFrameSource 10 | , removeFrameSource 11 | , dirtyFrameSource 12 | -- * Pixel source 13 | , PixelSource(..) 14 | -- * Flip, Clip, Dirty 15 | , PageFlipFlag (..) 16 | , PageFlipFlags 17 | , DirtyAnnotation (..) 18 | , Clip (..) 19 | ) 20 | where 21 | 22 | import Haskus.System.Linux.ErrorCode 23 | import Haskus.System.Linux.Handle 24 | import Haskus.System.Linux.Graphics.PixelFormat 25 | import Haskus.System.Linux.Graphics.Entities 26 | import Haskus.System.Linux.Internals.Graphics 27 | import Haskus.Format.Binary.Vector as Vector 28 | import Haskus.Format.Binary.Word 29 | import Foreign.Ptr 30 | import Haskus.Format.Binary.Storable 31 | import Haskus.Utils.Tuple 32 | import Haskus.Utils.Flow 33 | import Haskus.Utils.List (zip4) 34 | 35 | 36 | fromFrameSource :: FrameSource -> StructFrameBufferCommand 37 | fromFrameSource FrameSource{..} = s 38 | where 39 | g :: (Num a,Storable a) => (PixelSource -> a) -> Vector 4 a 40 | g f = Vector.fromFilledList 0 (fmap f frameSources) 41 | s = StructFrameBufferCommand (unEntityID frameID) 42 | frameWidth frameHeight framePixelFormat frameFlags 43 | (g surfaceHandle) (g surfacePitch) 44 | (g surfaceOffset) (g surfaceModifiers) 45 | 46 | toFrameSource :: StructFrameBufferCommand -> FrameSource 47 | toFrameSource StructFrameBufferCommand{..} = s 48 | where 49 | bufs = uncurry4 PixelSource <$> zip4 50 | (Vector.toList fc2Handles) 51 | (Vector.toList fc2Pitches) 52 | (Vector.toList fc2Offsets) 53 | (Vector.toList fc2Modifiers) 54 | s = FrameSource (EntityID fc2FbId) 55 | fc2Width fc2Height fc2PixelFormat fc2Flags bufs 56 | 57 | 58 | -- | Create a framebuffer 59 | addFrameSource :: MonadInIO m => Handle -> Word32 -> Word32 -> PixelFormat -> FrameBufferFlags -> [PixelSource] -> Excepts '[ErrorCode] m FrameSource 60 | addFrameSource hdl width height fmt flags buffers = do 61 | 62 | let s = FrameSource (EntityID 0) width height 63 | fmt flags buffers 64 | 65 | ioctlAddFrameBuffer (fromFrameSource s) hdl 66 | ||> toFrameSource 67 | 68 | -- | Release a frame buffer 69 | removeFrameSource :: MonadInIO m => Handle -> FrameSource -> Excepts '[ErrorCode] m () 70 | removeFrameSource hdl fs = do 71 | void (ioctlRemoveFrameBuffer (unEntityID (frameID fs)) hdl) 72 | 73 | 74 | -- | Indicate dirty parts of a frame source 75 | dirtyFrameSource :: MonadInIO m => Handle -> FrameSource -> DirtyAnnotation -> Excepts '[ErrorCode] m () 76 | dirtyFrameSource hdl fs mode = do 77 | let 78 | (color,flags,clips) = case mode of 79 | Dirty cs -> (0,0,cs) 80 | DirtyCopy cs -> (0,1, concatMap (\(a,b) -> [a,b]) cs) 81 | DirtyFill c cs -> (c,2,cs) 82 | 83 | void $ withArray clips $ \clipPtr -> do 84 | let s = StructFrameBufferDirty 85 | { fdFbId = unEntityID (frameID fs) 86 | , fdFlags = flags 87 | , fdColor = color 88 | , fdNumClips = fromIntegral (length clips) 89 | , fdClipsPtr = fromIntegral (ptrToWordPtr clipPtr) 90 | } 91 | ioctlDirtyFrameBuffer s hdl 92 | 93 | 94 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/Helper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- | Helpers for the graphics API 4 | module Haskus.System.Linux.Graphics.Helper 5 | ( FrameSourceAction (..) 6 | , setController 7 | , switchFrameSource 8 | ) 9 | where 10 | 11 | import Haskus.System.Linux.Graphics.State 12 | import Haskus.System.Linux.Graphics.Mode 13 | import Haskus.System.Linux.Graphics.FrameSource 14 | import Haskus.System.Linux.Graphics.Entities 15 | import Haskus.System.Linux.ErrorCode 16 | import Haskus.Format.Binary.Word 17 | import Haskus.Utils.Flow 18 | 19 | -- | How to configure frame source with setController 20 | data FrameSourceAction 21 | = SetSource FrameSource -- ^ Use this given source 22 | | ReuseSource -- ^ Use the already set one 23 | | ReleaseSource -- ^ Release the set source 24 | deriving (Show) 25 | 26 | -- | Configure a controller 27 | -- 28 | -- A connected frame source is required to set a mode: if ReuseSource is passed, the 29 | -- connected one is used. 30 | setController :: MonadInIO m => Controller -> FrameSourceAction -> [Connector] -> Maybe Mode -> Excepts '[ErrorCode] m () 31 | setController ctrl frameSourceAction conns mode = do 32 | let 33 | mframe = case frameSourceAction of 34 | SetSource fs -> Just $ Frame (frameID fs) 0 0 35 | ReuseSource -> Just $ Frame (EntityID maxBound) 0 0 36 | ReleaseSource -> Nothing 37 | hdl = controllerHandle ctrl 38 | setController' hdl (controllerID ctrl) mframe (fmap connectorID conns) mode 39 | 40 | -- | Switch to another frame source for the given controller without doing a 41 | -- full mode change 42 | switchFrameSource :: MonadInIO m => Controller -> FrameSource -> PageFlipFlags -> Word64 -> Excepts '[ErrorCode] m () 43 | switchFrameSource ctrl fs flags udata = 44 | switchFrameBuffer' (controllerHandle ctrl) (controllerID ctrl) (frameID fs) flags udata 45 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/HostBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | -- | Host buffers 6 | -- 7 | -- Host buffers are unaccelerated buffers that can be used with all devices 8 | -- that support them with the same API (contrary to accelerated buffers) 9 | -- 10 | -- Host buffers are called "dumb buffers" in original terminology 11 | -- 12 | module Haskus.System.Linux.Graphics.HostBuffer 13 | ( HostBuffer 14 | , HostBufferMap 15 | , createHostBuffer 16 | , destroyHostBuffer 17 | , mapHostBuffer 18 | ) 19 | where 20 | 21 | import Haskus.System.Linux.ErrorCode 22 | import Haskus.System.Linux.Handle 23 | import Haskus.System.Linux.Internals.Graphics 24 | import Haskus.Utils.Flow 25 | import Haskus.Format.Binary.Word 26 | 27 | type HostBuffer = StructCreateDumb 28 | type HostBufferMap = StructMapDumb 29 | 30 | -- | Create a host buffer 31 | createHostBuffer :: MonadInIO m => Handle -> Word32 -> Word32 -> Word32 -> Word32 -> Excepts '[ErrorCode] m HostBuffer 32 | createHostBuffer hdl width height bpp flags = do 33 | let s = StructCreateDumb height width bpp flags 0 0 0 34 | ioctlCreateHostBuffer s hdl 35 | 36 | -- | Destroy a host buffer 37 | destroyHostBuffer :: MonadInIO m => Handle -> HostBuffer -> Excepts '[ErrorCode] m () 38 | destroyHostBuffer hdl buffer = do 39 | let s = StructDestroyDumb (cdHandle buffer) 40 | void (ioctlDestroyHostBuffer s hdl) 41 | 42 | -- | Map a host buffer 43 | mapHostBuffer :: MonadInIO m => Handle -> HostBuffer -> Excepts '[ErrorCode] m HostBufferMap 44 | mapHostBuffer hdl buffer = do 45 | let s = StructMapDumb (cdHandle buffer) 0 0 46 | ioctlMapHostBuffer s hdl 47 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Graphics/Mode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Display mode (resolution, refresh rate, etc.) 6 | module Haskus.System.Linux.Graphics.Mode 7 | ( Mode(..) 8 | , ModeType(..) 9 | , ModeTypes 10 | , ModeFlag(..) 11 | , ModeFlags 12 | -- * Low level 13 | , fromStructMode 14 | , toStructMode 15 | ) 16 | where 17 | 18 | import Haskus.Format.Binary.BitField 19 | import Haskus.Format.Binary.Enum 20 | import Haskus.Format.Binary.Word 21 | import Foreign.Ptr (castPtr) 22 | import Haskus.Format.Binary.Storable 23 | import Haskus.Format.String 24 | import Haskus.System.Linux.Internals.Graphics 25 | 26 | -- | Display mode 27 | data Mode = Mode 28 | { modeClock :: !Word32 29 | 30 | , modeHorizontalDisplay :: !Word16 31 | , modeHorizontalSyncStart :: !Word16 32 | , modeHorizontalSyncEnd :: !Word16 33 | , modeHorizontalTotal :: !Word16 34 | , modeHorizontalSkew :: !Word16 35 | 36 | , modeVerticalDisplay :: !Word16 37 | , modeVerticalSyncStart :: !Word16 38 | , modeVerticalSyncEnd :: !Word16 39 | , modeVerticalTotal :: !Word16 40 | , modeVerticalScan :: !Word16 41 | 42 | , modeVerticalRefresh :: !Word32 43 | , modeFlags :: !ModeFlags 44 | , modeStereo3D :: !Stereo3D 45 | , modeType :: !ModeTypes 46 | , modeName :: !String 47 | } deriving (Show) 48 | 49 | instance Storable Mode where 50 | sizeOf _ = sizeOfT @StructMode 51 | alignment _ = alignmentT @StructMode 52 | peekIO v = fromStructMode <$> peekIO (castPtr v) 53 | pokeIO p v = pokeIO (castPtr p) (toStructMode v) 54 | 55 | 56 | fromStructMode :: StructMode -> Mode 57 | fromStructMode StructMode {..} = 58 | let 59 | flgs = extractField @"flags" miFlags 60 | flg3d = fromEnumField $ extractField @"stereo3d" miFlags 61 | in Mode 62 | { modeClock = miClock 63 | , modeHorizontalDisplay = miHDisplay 64 | , modeHorizontalSyncStart = miHSyncStart 65 | , modeHorizontalSyncEnd = miHSyncEnd 66 | , modeHorizontalTotal = miHTotal 67 | , modeHorizontalSkew = miHSkew 68 | , modeVerticalDisplay = miVDisplay 69 | , modeVerticalSyncStart = miVSyncStart 70 | , modeVerticalSyncEnd = miVSyncEnd 71 | , modeVerticalTotal = miVTotal 72 | , modeVerticalScan = miVScan 73 | , modeVerticalRefresh = miVRefresh 74 | , modeFlags = flgs 75 | , modeStereo3D = flg3d 76 | , modeType = miType 77 | , modeName = fromCStringBuffer miName 78 | } 79 | 80 | toStructMode :: Mode -> StructMode 81 | toStructMode Mode {..} = 82 | let 83 | flgs = updateField @"flags" modeFlags 84 | $ updateField @"stereo3d" (toEnumField modeStereo3D) 85 | $ BitFields 0 86 | 87 | in StructMode 88 | { miClock = modeClock 89 | , miHDisplay = modeHorizontalDisplay 90 | , miHSyncStart = modeHorizontalSyncStart 91 | , miHSyncEnd = modeHorizontalSyncEnd 92 | , miHTotal = modeHorizontalTotal 93 | , miHSkew = modeHorizontalSkew 94 | , miVDisplay = modeVerticalDisplay 95 | , miVSyncStart = modeVerticalSyncStart 96 | , miVSyncEnd = modeVerticalSyncEnd 97 | , miVTotal = modeVerticalTotal 98 | , miVScan = modeVerticalScan 99 | , miVRefresh = modeVerticalRefresh 100 | , miFlags = flgs 101 | , miType = modeType 102 | , miName = toCStringBuffer modeName 103 | } 104 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Handle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Kernel object handle 6 | -- 7 | -- File descriptor in original terminology 8 | module Haskus.System.Linux.Handle 9 | ( Handle (..) 10 | , HandleFlag(..) 11 | , HandleFlags 12 | , getHandleFlags 13 | , setHandleFlags 14 | , InvalidHandle (..) 15 | , sysFcntl 16 | ) 17 | where 18 | 19 | import Haskus.System.Linux.Error 20 | import Haskus.System.Linux.ErrorCode 21 | import Haskus.System.Linux.Syscalls 22 | import Haskus.System.Linux.Internals.Arg 23 | import Haskus.System.Linux.Internals.Handle 24 | import Haskus.System.Linux.Internals.Fcntl 25 | import Haskus.Format.Binary.BitSet as BitSet 26 | import Haskus.Format.Binary.Word 27 | import Haskus.Format.Binary.Enum 28 | import Haskus.Utils.Flow 29 | 30 | -- | Fcntl syscall 31 | sysFcntl :: (MonadIO m, Arg a) => Handle -> FcntlCommand -> a -> Excepts '[ErrorCode] m Int64 32 | sysFcntl (Handle fd) cmd arg = 33 | checkErrorCode =<< liftIO (syscall_fcntl fd (fromCEnum cmd) (toArg arg)) 34 | 35 | 36 | -- | Get descriptor flags 37 | getHandleFlags :: MonadIO m => Handle -> Excepts '[InvalidHandle] m HandleFlags 38 | getHandleFlags hdl = do 39 | r <- sysFcntl hdl FcntlGetFlags (0 :: Int) 40 | `catchLiftBoth` \case 41 | EBADF -> failureE InvalidHandle 42 | e -> unhdlErr "getHandleFlags" e 43 | return (BitSet.fromBits (fromIntegral r)) 44 | 45 | -- | Set descriptor flags 46 | setHandleFlags :: MonadIO m => Handle -> HandleFlags -> Excepts '[InvalidHandle] m () 47 | setHandleFlags hdl flgs = 48 | void (sysFcntl hdl FcntlSetFlags (BitSet.toBits flgs)) 49 | `catchLiftBoth` \case 50 | EBADF -> failureE InvalidHandle 51 | e -> unhdlErr "setHandleFlags" e 52 | 53 | 54 | -- | Handle flags 55 | data HandleFlag 56 | = HandleWriteOnly 57 | | HandleReadWrite 58 | | HandleCloseOnExec 59 | | HandleAppend 60 | | HandleAsync 61 | | HandleCreate 62 | | HandleDirect 63 | | HandleDirectory 64 | | HandleExclusive 65 | | HandleLargeFile 66 | | HandleWithoutAccessTime 67 | | HandleNoTTYControl 68 | | HandleDontFollowSymLinks 69 | | HandleNonBlocking 70 | | HandlePath 71 | | HandleSynchronous 72 | | HandleTmpFile 73 | | HandleTruncate 74 | deriving (Show,Eq,Enum) 75 | 76 | -- | Handle flags 77 | type HandleFlags = BitSet Int HandleFlag 78 | 79 | instance CBitSet HandleFlag where 80 | toBitOffset x = case x of 81 | HandleWriteOnly -> 0 82 | HandleReadWrite -> 1 83 | HandleCreate -> 6 84 | HandleExclusive -> 7 85 | HandleNoTTYControl -> 8 86 | HandleTruncate -> 9 87 | HandleAppend -> 10 88 | HandleNonBlocking -> 11 89 | HandleSynchronous -> 12 90 | HandleAsync -> 13 91 | HandleDirect -> 14 92 | HandleLargeFile -> 15 93 | HandleDirectory -> 16 94 | HandleDontFollowSymLinks -> 17 95 | HandleWithoutAccessTime -> 18 96 | HandleCloseOnExec -> 19 97 | HandlePath -> 21 98 | HandleTmpFile -> 22 99 | 100 | fromBitOffset x = case x of 101 | 0 -> HandleWriteOnly 102 | 1 -> HandleReadWrite 103 | 6 -> HandleCreate 104 | 7 -> HandleExclusive 105 | 8 -> HandleNoTTYControl 106 | 9 -> HandleTruncate 107 | 10 -> HandleAppend 108 | 11 -> HandleNonBlocking 109 | 12 -> HandleSynchronous 110 | 13 -> HandleAsync 111 | 14 -> HandleDirect 112 | 15 -> HandleLargeFile 113 | 16 -> HandleDirectory 114 | 17 -> HandleDontFollowSymLinks 115 | 18 -> HandleWithoutAccessTime 116 | 19 -> HandleCloseOnExec 117 | 21 -> HandlePath 118 | 22 -> HandleTmpFile 119 | _ -> error "Unknown handle flag" 120 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | System info (uname) 7 | module Haskus.System.Linux.Info 8 | ( SystemInfo(..) 9 | , systemInfo 10 | ) 11 | where 12 | 13 | import Haskus.System.Linux.ErrorCode 14 | import Haskus.System.Linux.Syscalls 15 | import Haskus.Format.Binary.Storable 16 | import Foreign.Ptr 17 | import Haskus.Format.String 18 | import Haskus.Utils.Types.Generics (Generic) 19 | import Haskus.Utils.Flow 20 | 21 | -- | struct utsname 22 | data SystemInfo = SystemInfo 23 | { systemName :: CStringBuffer 65 -- ^ OS name 24 | , systemNodeName :: CStringBuffer 65 -- ^ Network name 25 | , systemRelease :: CStringBuffer 65 -- ^ Release 26 | , systemVersion :: CStringBuffer 65 -- ^ Version 27 | , systemMachine :: CStringBuffer 65 -- ^ Hardware identifier 28 | } deriving (Show,Generic,Storable) 29 | 30 | -- | "uname" syscall 31 | systemInfo :: MonadInIO m => Excepts '[ErrorCode] m SystemInfo 32 | systemInfo = alloca $ \(ptr :: Ptr SystemInfo) -> do 33 | checkErrorCode_ =<< liftIO (syscall_uname (castPtr ptr)) 34 | peek ptr 35 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Input.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | -- | Linux input 6 | module Haskus.System.Linux.Input 7 | ( getSupportedEvents 8 | ) 9 | where 10 | 11 | import Haskus.System.Linux.Internals.Input 12 | import Haskus.System.Linux.Handle 13 | import Haskus.System.Linux.ErrorCode 14 | import Haskus.Format.Binary.Buffer 15 | import Haskus.Utils.Flow 16 | 17 | 18 | -- | Call getDeviceBits until the buffer is large enough to contain all the 19 | -- event codes. Initial buffer size should be sensible size in *bits*. 20 | getDeviceBits :: MonadInIO m => Handle -> Maybe EventType -> Word -> Excepts '[ErrorCode] m Buffer 21 | getDeviceBits hdl ev bitSize = go ((bitSize + 7) `div` 8) 22 | where 23 | go sz = do 24 | (rdsz,b) <- ioctlGetDeviceBits ev (fromIntegral sz) hdl 25 | -- check that the buffer was large enough and splice it, otherwise retry 26 | -- with a larger buffer 27 | if rdsz == fromIntegral sz 28 | then go (2*sz) 29 | else return (bufferTake (fromIntegral rdsz) b) 30 | 31 | 32 | -- | Return the event types supported by the input device 33 | getSupportedEvents :: MonadInIO m => Handle -> Excepts '[ErrorCode] m Buffer 34 | getSupportedEvents hdl = do 35 | getDeviceBits hdl Nothing 0x20 36 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Arg.hs: -------------------------------------------------------------------------------- 1 | -- | Helper class to pass parameters to system calls 2 | module Haskus.System.Linux.Internals.Arg 3 | ( Arg (..) 4 | ) 5 | where 6 | 7 | import Haskus.Format.Binary.Word 8 | import Foreign.Ptr (Ptr, ptrToWordPtr) 9 | 10 | 11 | -- | Parameters that can be directly passed to system calls 12 | class Arg a where 13 | toArg :: a -> Int64 14 | 15 | instance Arg Bool where 16 | toArg True = 1 17 | toArg False = 0 18 | 19 | instance Arg Int where toArg = fromIntegral 20 | instance Arg Int32 where toArg = fromIntegral 21 | instance Arg Int64 where toArg = id 22 | instance Arg Word where toArg = fromIntegral 23 | instance Arg Word64 where toArg = fromIntegral 24 | instance Arg Word32 where toArg = fromIntegral 25 | instance Arg CUShort where toArg = fromIntegral 26 | instance Arg (Ptr a) where toArg = fromIntegral . ptrToWordPtr 27 | 28 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Fcntl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | 3 | -- | File control (fcntl) 4 | module Haskus.System.Linux.Internals.Fcntl 5 | ( FcntlCommand (..) 6 | ) 7 | where 8 | 9 | import Haskus.Format.Binary.Enum 10 | 11 | -- ============================================================= 12 | -- From linux/include/uapi/asm-generic/fcntl.h 13 | -- ============================================================= 14 | 15 | -- | File control command 16 | data FcntlCommand 17 | = FcntlDupHandle -- ^ dup 18 | | FcntlGetHandle -- ^ get close_on_exec 19 | | FcntlSetHandle -- ^ set/clear close_on_exec 20 | | FcntlGetFlags -- ^ get flags 21 | | FcntlSetFlags 22 | | FcntlGetLock 23 | | FcntlSetLock 24 | | FcntlSetLockWait 25 | | FcntlSetSocketOwner 26 | | FcntlGetSocketOwner 27 | | FcntlSetSocketSignal 28 | | FcntlGetSocketSignal 29 | | FcntlGetLock64 30 | | FcntlSetLock64 31 | | FcntlSetLockWait64 32 | | FcntlSetSockerOwnerEx 33 | | FcntlGetSocketOwnerEx 34 | | FcntlGetOwnerUIDs 35 | deriving (Show,Eq,Enum,CEnum) 36 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Handle.hs: -------------------------------------------------------------------------------- 1 | -- | Kernel object handle 2 | -- 3 | -- File descriptor in original terminology 4 | module Haskus.System.Linux.Internals.Handle 5 | ( Handle (..) 6 | ) 7 | where 8 | 9 | -- | Kernel object handle 10 | -- 11 | -- (file descriptor in original terminology) 12 | newtype Handle = Handle Word deriving (Show,Eq) 13 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Ioctl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | -- | IOCTL 8 | module Haskus.System.Linux.Internals.Ioctl 9 | ( Command (..) 10 | , Direction(..) 11 | , CommandType 12 | , CommandNumber 13 | , ioctlCommand 14 | , rawIoctlCommand 15 | ) 16 | where 17 | 18 | import Haskus.Format.Binary.BitField 19 | import Haskus.Format.Binary.Enum 20 | import Haskus.Format.Binary.Word 21 | import Haskus.Format.Binary.Storable 22 | 23 | 24 | -- ============================================================= 25 | -- From linux/include/uapi/asm-generic/ioctl.h 26 | -- ============================================================= 27 | 28 | 29 | -- ioctl command encoding: 32 bits total, command in lower 16 bits, 30 | -- size of the parameter structure in the lower 14 bits of the 31 | -- upper 16 bits. 32 | -- Encoding the size of the parameter structure in the ioctl request 33 | -- is useful for catching programs compiled with old versions 34 | -- and to avoid overwriting user space outside the user buffer area. 35 | -- The highest 2 bits are reserved for indicating the ``access mode''. 36 | -- NOTE: This limits the max parameter size to 16kB -1 ! 37 | -- 38 | 39 | -- | An IOCTL command number 40 | -- 41 | -- The fields are just conventional. Some IOCTLs don't respect them (e.g., use 42 | -- direction=None while they read and/or write, use non corresponding arg size, 43 | -- etc.) 44 | newtype Command = Command (BitFields Word32 45 | '[ BitField 2 "direction" (EnumField Word8 Direction) 46 | , BitField 14 "size" Word16 47 | , BitField 8 "type" CommandType 48 | , BitField 8 "number" CommandNumber 49 | ]) deriving (Storable) 50 | 51 | -- | Command type 52 | type CommandType = Word8 53 | 54 | -- | Command number 55 | type CommandNumber = Word8 56 | 57 | -- | Direction of the IOCTL 58 | data Direction 59 | = None 60 | | Write 61 | | Read 62 | | WriteRead 63 | deriving (Show,Eq,Enum) 64 | 65 | instance CEnum Direction 66 | 67 | -- | Encode a command (similar to _IO, _IOR, ... macros) 68 | ioctlCommand :: Direction -> Word8 -> Word8 -> Word -> Command 69 | {-# INLINE ioctlCommand #-} 70 | ioctlCommand dir typ nb sz = Command 71 | $ updateField @"direction" (toEnumField dir) 72 | $ updateField @"size" (fromIntegral sz) 73 | $ updateField @"type" typ 74 | $ updateField @"number" nb 75 | $ BitFields 0 76 | 77 | -- | Raw IOCTL command 78 | rawIoctlCommand :: Word32 -> Command 79 | rawIoctlCommand = Command . BitFields 80 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Reboot.hs: -------------------------------------------------------------------------------- 1 | -- | Linux 'reboot' syscall 2 | module Haskus.System.Linux.Internals.Reboot 3 | ( PowerCommand(..) 4 | , powerCommandNumber 5 | ) 6 | where 7 | 8 | import Haskus.Format.Binary.Word (Word64) 9 | 10 | -- ============================================================= 11 | -- From linux/include/uapi/linux/reboot.h 12 | -- ============================================================= 13 | 14 | -- | Commands supported by the reboot syscall 15 | data PowerCommand 16 | = PowerDisableRebootKeys -- ^ Ctrl-Alt-Del sequence sends SIGINT to init task. 17 | | PowerEnableRebootKeys -- ^ Ctrl-Alt-Del sequence causes RESTART command. 18 | | PowerHalt -- ^ Stop OS and give system control to ROM monitor, if any. 19 | | PowerKernelExec -- ^ Restart system using a previously loaded Linux kernel 20 | | PowerOff -- ^ Stop OS and remove all power from system, if possible. 21 | | PowerRestart -- ^ Restart system using default command and mode. 22 | | PowerRestartCommand String -- ^ Restart system using given command string. 23 | | PowerSoftSuspend -- ^ Suspend system using software suspend if compiled in. 24 | deriving (Show,Eq) 25 | 26 | -- | Convert a power command into its magic number 27 | powerCommandNumber :: PowerCommand -> Word64 28 | powerCommandNumber x = case x of 29 | PowerDisableRebootKeys -> 0x00000000 30 | PowerEnableRebootKeys -> 0x89ABCDEF 31 | PowerHalt -> 0xCDEF0123 32 | PowerKernelExec -> 0x45584543 33 | PowerOff -> 0x4321FEDC 34 | PowerRestart -> 0x01234567 35 | PowerRestartCommand _ -> 0xA1B2C3D4 36 | PowerSoftSuspend -> 0xD000FCE2 37 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Internals/Tables.hs: -------------------------------------------------------------------------------- 1 | -- | Static tables 2 | module Haskus.System.Linux.Internals.Tables 3 | ( errorTable 4 | , errorTableMax 5 | , keyTable 6 | , keyTableMax 7 | , computeHoles 8 | ) 9 | where 10 | 11 | import Haskus.Format.Binary.Word 12 | import Haskus.Format.Binary.Storable 13 | import Data.List (sort) 14 | 15 | -- | Maximal value in the error table 16 | errorTableMax :: Word 17 | errorTableMax = 133 18 | 19 | -- | Error codes (EPERM, ENOENT, etc.) 20 | errorTable :: [Word8] 21 | errorTable = fmap fromIntegral $ computeHoles errorTableMax [0,41,58] 22 | 23 | 24 | -- | Maximal value in the key table 25 | keyTableMax :: Word 26 | keyTableMax = 0x300 27 | 28 | -- | Permutation table for input keys (keys are Word16) 29 | keyTable :: [Word8] 30 | keyTable = concatMap wordBytes keyTable' 31 | where 32 | keyTable' :: [Word16] 33 | keyTable' = fmap fromIntegral $ computeHoles keyTableMax $ 34 | [84] ++ [195..199] ++ [249..255] ++ [0x10a..0x10f] 35 | ++ [0x118..0x11f] ++ [0x12c..0x12e] 36 | ++ [0x13f] ++ [0x149] ++ [0x152..0x15f] 37 | ++ [0x1bb..0x1bf] ++ [0x1c4..0x1cf] 38 | ++ [0x1e5..0x1f0] ++ [0x1fb..0x1ff] ++ [0x21f] 39 | ++ [0x224..0x22f] ++ [0x231..0x23f] 40 | ++ [0x247..0x24f] ++ [0x252..0x25f] 41 | ++ [0x277..0x2bf] ++ [0x2e8..0x2ff] 42 | 43 | -- | Compute a permutation table from a list of holes 44 | computeHoles :: Word -> [Word] -> [Word] 45 | computeHoles imax holes = go 0 0 (sort holes) 46 | where 47 | go i _ _ | i > imax = [] 48 | go i n (x:xs) | i == x = (imax -1 - n) : go (i+1) (n+1) xs 49 | go i n xs = (i - n) : go (i+1) n xs 50 | 51 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/KernelEvent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Kernel events are sent by the kernel to indicate that something 4 | -- changed in the device tree (e.g. device (un)plugged, moved, etc.) 5 | module Haskus.System.Linux.KernelEvent 6 | ( KernelEvent(..) 7 | , KernelEventAction(..) 8 | , parseKernelEvent 9 | ) 10 | where 11 | 12 | import Haskus.Format.Binary.Buffer 13 | import Haskus.Format.Text (Text) 14 | import qualified Haskus.Format.Text as Text 15 | 16 | import Data.Map (Map) 17 | import qualified Data.Map as Map 18 | 19 | -- | A kernel event 20 | data KernelEvent = KernelEvent 21 | { kernelEventAction :: KernelEventAction -- ^ What happened 22 | , kernelEventDevPath :: Text -- ^ Concerned device 23 | , kernelEventSubSystem :: Text -- ^ Device subsystem 24 | , kernelEventDetails :: Map Text Text -- ^ Event details 25 | } deriving Show 26 | 27 | -- | Kernel event type of action 28 | data KernelEventAction 29 | = ActionAdd -- ^ A device has been added 30 | | ActionRemove -- ^ A device has been removed 31 | | ActionChange -- ^ A device state has been modified 32 | | ActionOnline -- ^ A device is now on-line 33 | | ActionOffline -- ^ A device is now off-line 34 | | ActionMove -- ^ A device has been moved 35 | | ActionOther Text -- ^ Other action 36 | deriving (Show) 37 | 38 | -- | Parse a kernel event 39 | -- 40 | -- Kernel events are received as several zero-terminal strings. The first line 41 | -- isn't very useful because it is redundant with the content of the following 42 | -- lines. The following lines have the "key=value" format. 43 | -- 44 | -- Note: when kernel event sockets are used with a classic Linux distribution 45 | -- using udev, libudev injects its own events with their own syntax to perform 46 | -- netlink communication between processes (expected to be replaced with kdbus 47 | -- at some point). Hence we discard these events (they all begin with "libudev" 48 | -- characters) and return Nothing. 49 | parseKernelEvent :: Buffer -> Maybe KernelEvent 50 | parseKernelEvent bs = r 51 | where 52 | bss = fmap Text.bufferDecodeUtf8 (bufferSplitOn 0 bs) 53 | r = case bss of 54 | -- filter out injected libudev events 55 | ("libudev":_) -> Nothing 56 | _ -> Just (KernelEvent action devpath subsys details) 57 | 58 | -- parse fields 59 | fields = Map.fromList -- create Map from (key,value) tuples 60 | . fmap (toTuple . Text.splitOn "=") -- split "key=value" 61 | . filter (not . Text.null) -- drop empty lines 62 | $ tail bss -- drop the first line (it contains redundant info) 63 | 64 | action = case fields Map.! "ACTION" of 65 | "add" -> ActionAdd 66 | "remove" -> ActionRemove 67 | "change" -> ActionChange 68 | "online" -> ActionOnline 69 | "offline"-> ActionOffline 70 | "move" -> ActionMove 71 | x -> ActionOther x 72 | 73 | devpath = fields Map.! "DEVPATH" 74 | 75 | subsys = fields Map.! "SUBSYSTEM" 76 | 77 | -- remove mandatory fields from the "details" field 78 | details = Map.delete "SUBSYSTEM" 79 | . Map.delete "ACTION" 80 | $ Map.delete "DEVPATH" fields 81 | 82 | toTuple (x:y:_) = (x,y) 83 | toTuple x = error $ "Invalid tuple: " ++ show x 84 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Modules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | 6 | -- | Kernel module management 7 | module Haskus.System.Linux.Modules 8 | ( loadModuleFromFile 9 | , loadModuleFromMemory 10 | , LoadModuleFlag(..) 11 | , LoadModuleFlags 12 | ) 13 | where 14 | 15 | import Haskus.System.Linux.ErrorCode 16 | import Haskus.System.Linux.Handle 17 | import Haskus.System.Linux.Syscalls 18 | import Haskus.Format.Binary.BitSet as BitSet 19 | import Haskus.Format.Binary.Word 20 | import Foreign.Ptr 21 | import Haskus.Format.String (withCString) 22 | import Haskus.Utils.Flow 23 | 24 | 25 | -- | Load module flag 26 | data LoadModuleFlag 27 | = IgnoreSymbolVersions 28 | | IgnoreKernelVersion 29 | deriving (Show,Eq,Enum,CBitSet) 30 | 31 | -- | Load module flags 32 | type LoadModuleFlags = BitSet Word LoadModuleFlag 33 | 34 | -- | Load a module from a file 35 | loadModuleFromFile :: MonadInIO m => Handle -> String -> LoadModuleFlags -> Excepts '[ErrorCode] m () 36 | loadModuleFromFile (Handle fd) params flags = do 37 | withCString params $ \params' -> 38 | checkErrorCode_ =<< liftIO (syscall_finit_module fd params' (BitSet.toBits flags)) 39 | 40 | -- | Load a module from memory 41 | loadModuleFromMemory :: MonadInIO m => Ptr () -> Word64 -> String -> Excepts '[ErrorCode] m () 42 | loadModuleFromMemory ptr sz params = 43 | withCString params $ \params' -> 44 | checkErrorCode_ =<< liftIO (syscall_init_module ptr sz params') 45 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Network/SendReceive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Haskus.System.Linux.Network.SendReceive 7 | ( SendReceiveFlag(..) 8 | , SendReceiveFlags 9 | , sysReceive 10 | , receiveBuffer 11 | ) 12 | where 13 | 14 | import Haskus.System.Linux.ErrorCode 15 | import Haskus.System.Linux.Handle 16 | import Haskus.System.Linux.Syscalls 17 | import Haskus.Format.Binary.BitSet as BitSet 18 | import Haskus.Format.Binary.Word 19 | import Haskus.Format.Binary.Storable 20 | import Haskus.Format.Binary.Buffer 21 | import Haskus.Utils.Flow 22 | 23 | import Foreign.Ptr 24 | import Foreign.Marshal.Alloc(free,mallocBytes) 25 | 26 | 27 | data SendReceiveFlag 28 | = FlagOutOfBand -- ^ Process out-of-band data 29 | | FlagPeek -- ^ Peek at incoming messages 30 | | FlagDontRoute -- ^ Don't use local routing 31 | | FlagTruncateControl -- ^ Control data lost before delivery 32 | | FlagProxy -- ^ Supply or ask second address 33 | | FlagTruncate 34 | | FlagDontWait -- ^ Nonblocking IO 35 | | FlagEndOfRecord -- ^ End of record 36 | | FlagWaitAll -- ^ Wait for a full request 37 | | FlagFIN 38 | | FlagSYN 39 | | FlagConfirm -- ^ Confirm path validity 40 | | FlagRST 41 | | FlagFetchErrorQueue -- ^ Fetch message from error queue 42 | | FlagNoSignal -- ^ Do not generate SIGPIPE 43 | | FlagMore -- ^ Sender will send more 44 | | FlagWaitForOne -- ^ Wait for at least one packet to return 45 | | FlagFastOpen -- ^ Send data in TCP SYN 46 | | FlagCloseOnExec -- ^ Set close_on_exit for file descriptor received through SCM_RIGHTS 47 | deriving (Show,Eq,CBitSet) 48 | 49 | instance Enum SendReceiveFlag where 50 | fromEnum x = case x of 51 | FlagOutOfBand -> 0 52 | FlagPeek -> 1 53 | FlagDontRoute -> 2 54 | FlagTruncateControl -> 3 55 | FlagProxy -> 4 56 | FlagTruncate -> 5 57 | FlagDontWait -> 6 58 | FlagEndOfRecord -> 7 59 | FlagWaitAll -> 8 60 | FlagFIN -> 9 61 | FlagSYN -> 10 62 | FlagConfirm -> 11 63 | FlagRST -> 12 64 | FlagFetchErrorQueue -> 13 65 | FlagNoSignal -> 14 66 | FlagMore -> 15 67 | FlagWaitForOne -> 16 68 | FlagFastOpen -> 29 69 | FlagCloseOnExec -> 30 70 | toEnum x = case x of 71 | 0 -> FlagOutOfBand 72 | 1 -> FlagPeek 73 | 2 -> FlagDontRoute 74 | 3 -> FlagTruncateControl 75 | 4 -> FlagProxy 76 | 5 -> FlagTruncate 77 | 6 -> FlagDontWait 78 | 7 -> FlagEndOfRecord 79 | 8 -> FlagWaitAll 80 | 9 -> FlagFIN 81 | 10 -> FlagSYN 82 | 11 -> FlagConfirm 83 | 12 -> FlagRST 84 | 13 -> FlagFetchErrorQueue 85 | 14 -> FlagNoSignal 86 | 15 -> FlagMore 87 | 16 -> FlagWaitForOne 88 | 29 -> FlagFastOpen 89 | 30 -> FlagCloseOnExec 90 | _ -> error "Unknown send-receive flag" 91 | 92 | type SendReceiveFlags = BitSet Word64 SendReceiveFlag 93 | 94 | -- | Receive data from a socket 95 | -- 96 | -- recvfrom syscall 97 | sysReceive :: (MonadInIO m, Storable a) => Handle -> Ptr () -> Word64 -> SendReceiveFlags -> Maybe a -> Excepts '[ErrorCode] m Word64 98 | sysReceive (Handle fd) ptr size flags addr = do 99 | let 100 | call add len = do 101 | r <- liftIO (syscall_recvfrom fd ptr size (BitSet.toBits flags) (castPtr add) len) 102 | fromIntegral <$> checkErrorCode r 103 | 104 | case addr of 105 | Nothing -> call nullPtr nullPtr 106 | Just a -> with a $ \a' -> 107 | with (sizeOf' a) $ \sptr -> call a' sptr 108 | 109 | receiveBuffer :: MonadInIO m => Handle -> Int -> SendReceiveFlags -> Excepts '[ErrorCode] m Buffer 110 | receiveBuffer fd size flags = do 111 | b <- liftIO <| mallocBytes (fromIntegral size) 112 | sz <- (sysReceive fd b (fromIntegral size) flags (Nothing :: Maybe Int)) 113 | -- free the buffer on error 114 | `onE_` liftIO (free b) 115 | -- otherwise make a bytestring 116 | bufferPackPtr (fromIntegral sz) (castPtr b) 117 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Pipe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Pipe 6 | module Haskus.System.Linux.Pipe 7 | ( createPipe 8 | ) 9 | where 10 | 11 | import Haskus.System.Linux.ErrorCode 12 | import Haskus.System.Linux.Handle 13 | import Haskus.System.Linux.Syscalls 14 | import Foreign.Ptr 15 | import Haskus.Format.Binary.Storable 16 | import Haskus.Utils.Flow 17 | 18 | -- | Create a pipe 19 | createPipe :: MonadInIO m => Excepts '[ErrorCode] m (Handle, Handle) 20 | createPipe = 21 | allocaArray 2 $ \(ptr :: Ptr Word) -> do 22 | checkErrorCode_ =<< liftIO (syscall_pipe (castPtr ptr)) 23 | (,) <$> (Handle <$> peekElemOff ptr 0) 24 | <*> (Handle <$> peekElemOff ptr 1) 25 | 26 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Power.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Power-off, reboot, etc. 6 | module Haskus.System.Linux.Power 7 | ( sysPower 8 | , disableRebootKeys 9 | , enableRebootKeys 10 | , halt 11 | , executeLoadedKernel 12 | , powerOff 13 | , restart 14 | , restartWithCommand 15 | , softSuspend 16 | ) 17 | where 18 | 19 | import Haskus.System.Linux.Internals.Reboot 20 | import Haskus.System.Linux.Internals.Error 21 | import Haskus.System.Linux.Syscalls 22 | import Haskus.System.Linux.Error 23 | import Haskus.System.Linux.ErrorCode 24 | import Haskus.Format.Binary.Word (Word64) 25 | import Haskus.Format.String (withCString) 26 | import Foreign.Ptr (nullPtr) 27 | import Haskus.Utils.Flow 28 | 29 | -- | reboot syscall 30 | sysPower :: MonadInIO m => PowerCommand -> Excepts '[ErrorCode] m () 31 | sysPower cmd = case cmd of 32 | PowerRestartCommand cmdPath -> withCString cmdPath f 33 | _ -> f nullPtr 34 | where 35 | f path = checkErrorCode_ =<< liftIO (syscall_reboot magic1 magic2 cmd' path) 36 | magic1 = 0xfee1dead :: Word64 37 | magic2 = 0x28121969 :: Word64 38 | cmd' = powerCommandNumber cmd 39 | 40 | 41 | -- | Ctrl-Alt-Del sequence sends SIGINT to init task. 42 | disableRebootKeys :: MonadInIO m => Excepts '[NotAllowed] m () 43 | disableRebootKeys = sysPower PowerDisableRebootKeys 44 | `catchLiftBoth` \case 45 | EPERM -> failureE NotAllowed 46 | e -> unhdlErr "disableRebootKeys" e 47 | 48 | -- | Ctrl-Alt-Del sequence causes RESTART command. 49 | enableRebootKeys :: MonadInIO m => Excepts '[NotAllowed] m () 50 | enableRebootKeys = sysPower PowerEnableRebootKeys 51 | `catchLiftBoth` \case 52 | EPERM -> failureE NotAllowed 53 | e -> unhdlErr "enableRebootKeys" e 54 | 55 | -- | Stop OS and give system control to ROM monitor, if any. 56 | halt :: MonadInIO m => Excepts '[NotAllowed] m () 57 | halt = sysPower PowerHalt 58 | `catchLiftBoth` \case 59 | EPERM -> failureE NotAllowed 60 | e -> unhdlErr "halt" e 61 | 62 | -- | Restart system using a previously loaded Linux kernel 63 | executeLoadedKernel :: MonadInIO m => Excepts '[NotAllowed] m () 64 | executeLoadedKernel = sysPower PowerKernelExec 65 | `catchLiftBoth` \case 66 | EPERM -> failureE NotAllowed 67 | e -> unhdlErr "executeLoadedKernel" e 68 | 69 | -- | Stop OS and remove all power from system, if possible. 70 | powerOff :: MonadInIO m => Excepts '[NotAllowed] m () 71 | powerOff = sysPower PowerOff 72 | `catchLiftBoth` \case 73 | EPERM -> failureE NotAllowed 74 | e -> unhdlErr "powerOff" e 75 | 76 | -- | Restart system using default command and mode. 77 | restart :: MonadInIO m => Excepts '[NotAllowed] m () 78 | restart = sysPower PowerRestart 79 | `catchLiftBoth` \case 80 | EPERM -> failureE NotAllowed 81 | e -> unhdlErr "restart" e 82 | 83 | -- | Restart system using given command string. 84 | restartWithCommand :: MonadInIO m => String -> Excepts '[NotAllowed,MemoryError,InvalidRestartCommand] m () 85 | restartWithCommand cmd = sysPower (PowerRestartCommand cmd) 86 | `catchLiftLeft` \case 87 | EPERM -> throwE NotAllowed 88 | EFAULT -> throwE MemoryError 89 | EINVAL -> throwE InvalidRestartCommand 90 | e -> unhdlErr "restartWithCommand" e 91 | 92 | -- | Suspend system using software suspend if compiled in. 93 | softSuspend :: MonadInIO m => Excepts '[NotAllowed] m () 94 | softSuspend = sysPower PowerSoftSuspend 95 | `catchLiftBoth` \case 96 | EPERM -> failureE NotAllowed 97 | e -> unhdlErr "softSuspend" e 98 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | Process management 6 | module Haskus.System.Linux.Process 7 | ( ProcessID(..) 8 | , ThreadID(..) 9 | , UserID(..) 10 | , GroupID(..) 11 | , SessionID(..) 12 | , sysExit 13 | , sysGetCPU 14 | , sysGetProcessID 15 | , sysGetParentProcessID 16 | , sysGetRealUserID 17 | , sysGetEffectiveUserID 18 | , sysSetEffectiveUserID 19 | , sysGetRealGroupID 20 | , sysGetEffectiveGroupID 21 | , sysSetEffectiveGroupID 22 | , sysGetThreadID 23 | , sysFork 24 | , sysVFork 25 | , sysSchedulerYield 26 | ) 27 | where 28 | 29 | import Foreign.Ptr (Ptr, nullPtr) 30 | import Haskus.Format.Binary.Word 31 | import Haskus.Format.Binary.Storable 32 | import Haskus.System.Linux.Syscalls 33 | import Haskus.System.Linux.ErrorCode 34 | import Haskus.Utils.Flow 35 | 36 | -- | Process ID 37 | newtype ProcessID = ProcessID Word32 deriving (Show,Eq,Ord,Storable) 38 | 39 | -- | Thread ID 40 | newtype ThreadID = ThreadID Word32 deriving (Show,Eq,Ord,Storable) 41 | 42 | -- | User ID 43 | newtype UserID = UserID Word32 deriving (Show,Eq,Ord,Storable) 44 | 45 | -- | Group ID 46 | newtype GroupID = GroupID Word32 deriving (Show,Eq,Ord,Storable) 47 | 48 | -- | Session ID 49 | newtype SessionID = SessionID Word32 deriving (Show,Eq,Ord,Storable) 50 | 51 | -- | Exit the current process with the given return value 52 | -- This syscall does not return. 53 | sysExit :: Int64 -> IO () 54 | sysExit n = void (syscall_exit n) 55 | 56 | -- | Get CPU and NUMA node executing the current process 57 | sysGetCPU :: MonadInIO m => Excepts '[ErrorCode] m (Word,Word) 58 | sysGetCPU = 59 | alloca $ \cpu -> 60 | alloca $ \node -> do 61 | r <- liftIO (syscall_getcpu (cpu :: Ptr Word) (node :: Ptr Word) nullPtr) 62 | checkErrorCode_ r 63 | (,) <$> peek cpu <*> peek node 64 | 65 | -- | Return process ID 66 | sysGetProcessID :: IO ProcessID 67 | sysGetProcessID = ProcessID . fromIntegral <$> syscall_getpid 68 | 69 | -- | Return thread ID 70 | sysGetThreadID :: IO ThreadID 71 | sysGetThreadID = ThreadID . fromIntegral <$> syscall_gettid 72 | 73 | -- | Return parent process ID 74 | sysGetParentProcessID :: IO ProcessID 75 | sysGetParentProcessID = ProcessID . fromIntegral <$> syscall_getppid 76 | 77 | -- | Get real user ID of the calling process 78 | sysGetRealUserID :: IO UserID 79 | sysGetRealUserID = UserID . fromIntegral <$> syscall_getuid 80 | 81 | -- | Get effective user ID of the calling process 82 | sysGetEffectiveUserID :: IO UserID 83 | sysGetEffectiveUserID = UserID . fromIntegral <$> syscall_geteuid 84 | 85 | -- | Set effective user ID of the calling process 86 | sysSetEffectiveUserID :: MonadIO m => UserID -> Excepts '[ErrorCode] m () 87 | sysSetEffectiveUserID (UserID uid) = checkErrorCode_ =<< liftIO (syscall_setuid uid) 88 | 89 | -- | Get real group ID of the calling process 90 | sysGetRealGroupID :: IO GroupID 91 | sysGetRealGroupID = GroupID . fromIntegral <$> syscall_getgid 92 | 93 | -- | Get effective group ID of the calling process 94 | sysGetEffectiveGroupID :: IO GroupID 95 | sysGetEffectiveGroupID = GroupID . fromIntegral <$> syscall_getegid 96 | 97 | -- | Set effective group ID of the calling process 98 | sysSetEffectiveGroupID :: MonadIO m => GroupID -> Excepts '[ErrorCode] m () 99 | sysSetEffectiveGroupID (GroupID gid) = checkErrorCode_ =<< liftIO (syscall_setgid gid) 100 | 101 | -- | Create a child process 102 | sysFork :: MonadIO m => Excepts '[ErrorCode] m ProcessID 103 | sysFork = do 104 | v <- checkErrorCode =<< liftIO (syscall_fork) 105 | return (ProcessID (fromIntegral v)) 106 | 107 | -- | Create a child process and block parent 108 | sysVFork :: MonadIO m => Excepts '[ErrorCode] m ProcessID 109 | sysVFork = do 110 | v <- checkErrorCode =<< liftIO (syscall_vfork) 111 | return (ProcessID (fromIntegral v)) 112 | 113 | -- | Yield the processor 114 | sysSchedulerYield :: MonadIO m => Excepts '[ErrorCode] m () 115 | sysSchedulerYield = checkErrorCode_ =<< liftIO (syscall_sched_yield) 116 | 117 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Process/ControlGroup.hs: -------------------------------------------------------------------------------- 1 | -- | Control-groups 2 | module Haskus.System.Linux.Process.ControlGroup 3 | ( ControlGroupEntry (..) 4 | , readControlGroup 5 | , parseControlGroup 6 | ) 7 | where 8 | 9 | import Prelude hiding (takeWhile) 10 | 11 | import Text.Megaparsec 12 | import Text.Megaparsec.Char 13 | import Text.Megaparsec.Char.Lexer hiding (space) 14 | import Data.Void 15 | 16 | import Haskus.Format.Binary.Buffer (bufferReadFile) 17 | import Haskus.Format.Text (Text) 18 | import Haskus.Utils.Flow 19 | import qualified Haskus.Format.Text as Text 20 | 21 | type Parser = Parsec Void Text 22 | 23 | -- | Control group entry 24 | data ControlGroupEntry = ControlGroupEntry 25 | { cgroupHierarchy :: Int 26 | , cgroupSubsystems :: [Text] 27 | , cgroupOwner :: Text 28 | } deriving (Show) 29 | 30 | -- | Read /proc/[pid]/cgroup 31 | readControlGroup :: FilePath -> IO [ControlGroupEntry] 32 | readControlGroup p = do 33 | buf <- bufferReadFile p 34 | case parse parseControlGroup p (Text.bufferDecodeUtf8 buf) of 35 | Right v -> return v 36 | Left err -> error ("control group parsing error: "++ show err) 37 | 38 | -- | Read /proc/[pid]/maps files 39 | parseControlGroup :: Parser [ControlGroupEntry] 40 | parseControlGroup = parseFile 41 | where 42 | parseFile = do 43 | es <- many parseLine 44 | eof 45 | return es 46 | parseLine = do 47 | hier <- decimal 48 | void (char ':') 49 | subs <- Text.splitOn (Text.pack ",") . Text.pack <$> someTill anySingle (char ':') 50 | void (char ':') 51 | own <- Text.pack <$> manyTill anySingle eol 52 | return $ ControlGroupEntry hier subs own 53 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Process/MemoryMap.hs: -------------------------------------------------------------------------------- 1 | -- | Parser for /proc/*/maps 2 | module Haskus.System.Linux.Process.MemoryMap 3 | ( MemoryMapEntry (..) 4 | , MappingType (..) 5 | , Perm (..) 6 | , Sharing (..) 7 | , readMemoryMap 8 | , parseMemoryMap 9 | , memoryMapParser 10 | , memoryMapToBufferList 11 | , memoryMapToBuffer 12 | ) 13 | where 14 | 15 | import Prelude hiding (takeWhile) 16 | 17 | import Haskus.Format.Binary.Buffer 18 | import Haskus.Format.Binary.BufferList 19 | import Haskus.Format.Binary.Word 20 | import Foreign.Ptr (wordPtrToPtr) 21 | import qualified Haskus.Format.Text as Text 22 | import Haskus.Format.Text (Text,bufferDecodeUtf8) 23 | import Haskus.Utils.Flow 24 | 25 | import Data.Void 26 | import Text.Megaparsec 27 | import Text.Megaparsec.Char 28 | import Text.Megaparsec.Char.Lexer hiding (space) 29 | 30 | type Parser = Parsec Void Text 31 | 32 | -- | Memory map entry 33 | data MemoryMapEntry = MemoryMapEntry 34 | { entryStartAddr :: Word64 -- ^ Starting address 35 | , entryStopAddr :: Word64 -- ^ End address 36 | , entryPerms :: [Perm] -- ^ Permissions 37 | , entrySharing :: Sharing -- ^ Shared or copy-on-write 38 | , entryType :: MappingType -- ^ Type of mapping 39 | } deriving (Show) 40 | 41 | -- | Type of memory mapping 42 | data MappingType 43 | = AnonymousMapping -- ^ Anonymous mapping 44 | | NamedMapping Text -- ^ Mapping with a name 45 | -- | File mapping 46 | | FileMapping 47 | { fileMappingDevice :: (Word8,Word8) -- ^ Device containing the inode 48 | , fileMappingInode :: Int64 -- ^ Inode 49 | , fileMappingPath :: Text -- ^ File path 50 | , fileMappingOffset :: Word64 -- ^ Offset in the file 51 | } 52 | deriving (Show,Eq) 53 | 54 | -- | Memory permission 55 | data Perm 56 | = PermRead -- ^ Read allowed 57 | | PermWrite -- ^ Write allowed 58 | | PermExec -- ^ Execute allowed 59 | deriving (Eq,Show) 60 | 61 | -- | Memory sharing 62 | data Sharing 63 | = Shared -- ^ Shared 64 | | Private -- ^ Private (copy-on-write) 65 | deriving (Eq,Show) 66 | 67 | -- | Read /proc/[pid]/maps files 68 | readMemoryMap :: FilePath -> IO [MemoryMapEntry] 69 | readMemoryMap p = parseMemoryMap <$> bufferReadFile p 70 | 71 | -- | Parse a memory map in a buffer 72 | parseMemoryMap :: Buffer -> [MemoryMapEntry] 73 | parseMemoryMap b = 74 | case runParser memoryMapParser "" (bufferDecodeUtf8 b) of 75 | Right v -> v 76 | Left err -> error ("memory map parsing error: "++ show err) 77 | 78 | -- | Parse /proc/[pid]/maps files 79 | memoryMapParser :: Parser [MemoryMapEntry] 80 | memoryMapParser = parseFile 81 | where 82 | parseFile = manyTill parseLine eof 83 | parseLine = do 84 | start <- hexadecimal 85 | void (char '-') 86 | stop <- hexadecimal 87 | void spaceChar 88 | perms <- do 89 | r <- (char 'r' *> return [PermRead]) <|> (char '-' *> return []) 90 | w <- (char 'w' *> return [PermWrite]) <|> (char '-' *> return []) 91 | x <- (char 'x' *> return [PermExec]) <|> (char '-' *> return []) 92 | return (r++w++x) 93 | sharing <- (char 'p' *> return Private) 94 | <|> (char 's' *> return Shared) 95 | void spaceChar 96 | offset <- hexadecimal 97 | void spaceChar 98 | dev <- do 99 | major <- hexadecimal 100 | void (char ':') 101 | minor <- hexadecimal 102 | return (major,minor) 103 | void spaceChar 104 | inode <- decimal 105 | void (many (char ' ')) 106 | pth <- Text.pack <$> manyTill anySingle eol 107 | let typ = case (inode, Text.null pth) of 108 | (0,True) -> AnonymousMapping 109 | (0,False) -> NamedMapping pth 110 | _ -> FileMapping dev inode pth offset 111 | return $ MemoryMapEntry start stop perms sharing typ 112 | 113 | -- | Convert a memory-map entry into a BufferList 114 | memoryMapToBufferList :: MemoryMapEntry -> IO BufferList 115 | memoryMapToBufferList = fmap toBufferList . memoryMapToBuffer 116 | 117 | -- | Convert a memory-map entry into a Buffer 118 | -- 119 | -- Warning: The buffer directly maps the entry (i.e. there is no copy of the 120 | -- data). Hence the referential transparency can be broken if the entry is 121 | -- written into 122 | memoryMapToBuffer :: MemoryMapEntry -> IO Buffer 123 | memoryMapToBuffer e = bufferUnsafeMapMemory len ptr 124 | where 125 | ptr = wordPtrToPtr (fromIntegral (entryStartAddr e)) 126 | len = fromIntegral $ entryStopAddr e - entryStartAddr e 127 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Signal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | -- | Linux signals 8 | module Haskus.System.Linux.Signal 9 | ( SignalSet(..) 10 | , ChangeSignals(..) 11 | , sysPause 12 | , sysAlarm 13 | , sysSendSignal 14 | , sysSendSignalGroup 15 | , sysSendSignalAll 16 | , sysCheckProcess 17 | , sysChangeSignalMask 18 | ) 19 | where 20 | 21 | import Haskus.System.Linux.ErrorCode 22 | import Haskus.System.Linux.Syscalls 23 | import Haskus.System.Linux.Process 24 | import Haskus.Format.Binary.Vector (Vector) 25 | import Haskus.Format.Binary.Word 26 | import Foreign.Ptr 27 | import Haskus.Format.Binary.Storable 28 | import Haskus.Utils.Flow 29 | import Haskus.Memory.Utils 30 | 31 | -- | Signal set 32 | newtype SignalSet = SignalSet (Vector 16 Word64) deriving (Storable) 33 | 34 | -- | Pause 35 | sysPause :: MonadIO m => Excepts '[ErrorCode] m () 36 | sysPause = checkErrorCode_ =<< liftIO (syscall_pause) 37 | 38 | -- | Alarm 39 | sysAlarm :: MonadIO m => Word-> Excepts '[ErrorCode] m Word 40 | sysAlarm seconds = fromIntegral <$> (checkErrorCode =<< liftIO (syscall_alarm seconds)) 41 | 42 | -- | Kill syscall 43 | sysSendSignal :: MonadIO m => ProcessID -> Int -> Excepts '[ErrorCode] m () 44 | sysSendSignal (ProcessID pid) sig = 45 | checkErrorCode_ =<< liftIO (syscall_kill (fromIntegral pid) sig) 46 | 47 | -- | Send a signal to every process in the process group of the calling process 48 | sysSendSignalGroup :: MonadIO m => Int -> Excepts '[ErrorCode] m () 49 | sysSendSignalGroup sig = checkErrorCode_ =<< liftIO (syscall_kill 0 sig) 50 | 51 | -- | Send a signal to every process for which the calling process has permission to send signals, except for process 1 (init) 52 | sysSendSignalAll :: MonadIO m => Int -> Excepts '[ErrorCode] m () 53 | sysSendSignalAll sig = checkErrorCode_ =<< liftIO (syscall_kill (-1) sig) 54 | 55 | -- | Check if a given process or process group exists 56 | -- 57 | -- Send signal "0" to the given process/process group 58 | sysCheckProcess :: MonadIO m => ProcessID -> Excepts '[ErrorCode] m Bool 59 | sysCheckProcess pid = 60 | (sysSendSignal pid 0 >> return True) 61 | -- ESRCH indicates that the process wasn't found 62 | -- Other errors are left unchanged 63 | `catchE` (\case 64 | ESRCH -> pure False 65 | e -> failureE e 66 | ) 67 | 68 | -- | Signal actions 69 | data ChangeSignals 70 | = BlockSignals -- ^ Block signals in the set 71 | | UnblockSignals -- ^ Unblock signals in the set 72 | | SetSignals -- ^ Set blocked signals to the set 73 | deriving (Show,Eq,Enum) 74 | 75 | -- | Change signal mask 76 | sysChangeSignalMask :: MonadInIO m => ChangeSignals -> Maybe SignalSet -> Excepts '[ErrorCode] m SignalSet 77 | sysChangeSignalMask act set = 78 | withMaybeOrNull set $ \x -> 79 | alloca $ \(ret :: Ptr SignalSet) -> do 80 | r <- liftIO (syscall_rt_sigprocmask (fromEnum act) (castPtr x) (castPtr ret)) 81 | checkErrorCode_ r 82 | liftIO (peek ret) 83 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Sound/Pcm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | PCM devices 4 | module Haskus.System.Linux.Sound.Pcm 5 | ( anyInterval 6 | , anyMask 7 | , anyParams 8 | , PcmConfig (..) 9 | , toConfig 10 | ) 11 | where 12 | 13 | import Haskus.System.Linux.Internals.Sound 14 | import qualified Haskus.Format.Binary.BitSet as BitSet 15 | import Haskus.Format.Binary.BitSet (CBitSet) 16 | import qualified Haskus.Format.Binary.Vector as Vector 17 | import Haskus.Format.Binary.Bits (complement,zeroBits) 18 | 19 | import Data.Set (Set) 20 | import qualified Data.Set as Set 21 | 22 | 23 | -- Note [PCM params] 24 | -- ~~~~~~~~~~~~~~~~~ 25 | -- 26 | -- PCM devices can be used to play sounds by supplying them samples. But first 27 | -- we need to configure them by setting: buffer size, sample rate, pcm data 28 | -- format, etc. 29 | -- 30 | -- There are two kinds of parameters: sets (or masks) and intervals. 31 | -- - Set params allow us to choose amongst a predefined set of values. 32 | -- - Interval params allow us to choose any value in a given interval. 33 | -- 34 | -- The idea to set parameters is to start with the largest sets and intervals 35 | -- and to refine them until they contain a single value. At each refinement step 36 | -- we can check if the device supports the given configuration. 37 | 38 | -- | Any interval 39 | anyInterval :: Interval 40 | anyInterval = Interval 41 | { intervalMin = 0 42 | , intervalMax = maxBound 43 | , intervalOptions = BitSet.empty 44 | } 45 | 46 | -- | Any mask 47 | anyMask :: Mask 48 | anyMask = Mask (complement zeroBits) 49 | 50 | -- | Any parameter set 51 | anyParams :: PcmHwParams 52 | anyParams = PcmHwParams 53 | { pcmHwParamsFlags = BitSet.empty 54 | , pcmHwParamsMasks = Vector.replicate anyMask 55 | , pcmHwParamsIntervals = Vector.replicate anyInterval 56 | , pcmHwParamsRequestedMasks = maxBound -- retrieve all masks/intervals 57 | , pcmHwParamsChangedMasks = 0 -- nothing has been changed 58 | , pcmHwParamsInfo = maxBound -- return all info flags 59 | , pcmHwParamsMostSignificantBits = 0 60 | , pcmHwParamsRateNumerator = 0 61 | , pcmHwParamsRateDenominator = 0 62 | , pcmHwParamsFifoSize = 0 63 | , pcmHwParamsReserved = Vector.replicate 0 64 | } 65 | 66 | -- | PCM configuration 67 | data PcmConfig = PcmConfig 68 | { pcmConfigAccess :: Set PcmAccess 69 | , pcmConfigFormat :: Set PcmFormat 70 | , pcmConfigSubFormat :: Set PcmSubFormat 71 | -- TODO: add other fields (intervals...) 72 | } 73 | deriving (Show) 74 | 75 | -- | Convert raw PCM hw params into PcmConfig 76 | toConfig :: PcmHwParams -> PcmConfig 77 | toConfig params = PcmConfig 78 | { pcmConfigAccess = fromMask m1 79 | , pcmConfigFormat = fromMask m2 80 | , pcmConfigSubFormat = fromMask m3 81 | } 82 | where 83 | fromMask :: forall a. (Ord a, Bounded a, Enum a, CBitSet a) => Mask -> Set a 84 | fromMask (Mask v) = Set.fromList (BitSet.enumerateSetBits v) 85 | 86 | m1:m2:m3:_ = Vector.toList (pcmHwParamsMasks params) 87 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Syscalls.hs: -------------------------------------------------------------------------------- 1 | -- | Linux system calls (syscalls) 2 | module Haskus.System.Linux.Syscalls 3 | ( module Arch.Syscalls 4 | ) 5 | where 6 | 7 | --TODO: use conditional import here when we will support different 8 | --architectures 9 | import Haskus.Arch.X86_64.Linux.Syscalls as Arch.Syscalls 10 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Linux/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | -- | This module provides some functions to use Linux 5 | -- terminals 6 | module Haskus.System.Linux.Terminal 7 | ( stdin 8 | , stdout 9 | , stderr 10 | , writeStr 11 | , writeStrLn 12 | , readChar 13 | ) 14 | where 15 | 16 | import Haskus.System.Linux.ErrorCode 17 | import Haskus.System.Linux.FileSystem.ReadWrite 18 | import Haskus.System.Linux.Handle 19 | import Haskus.Utils.Flow 20 | import Haskus.Format.Text 21 | import Haskus.Format.String 22 | import Haskus.Format.Binary.Buffer 23 | 24 | -- | Standard input (by convention) 25 | stdin :: Handle 26 | stdin = Handle 0 27 | 28 | -- | Standard output (by convention) 29 | stdout :: Handle 30 | stdout = Handle 1 31 | 32 | -- | Standard error output (by convention) 33 | stderr :: Handle 34 | stderr = Handle 2 35 | 36 | -- | Write a String in the given file descriptor 37 | writeStr :: MonadInIO m => Handle -> String -> Excepts '[ErrorCode] m () 38 | writeStr fd = writeBuffer fd . stringEncodeUtf8 39 | 40 | -- | Write a String with a newline character in the given 41 | -- file descriptor 42 | writeStrLn :: MonadInIO m => Handle -> String -> Excepts '[ErrorCode] m () 43 | writeStrLn fd = writeBuffer fd . stringEncodeUtf8 . (++ "\n") 44 | 45 | -- | Read a single character 46 | -- 47 | -- Warning: only the first byte of multi-byte characters (e.g. utf8) will be 48 | -- read 49 | readChar :: MonadInIO m => Handle -> Excepts ReadErrors' m Char 50 | readChar fd = handleReadBuffer fd Nothing 1 51 | ||> (castCCharToChar . bufferPeekStorable) 52 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Network.hs: -------------------------------------------------------------------------------- 1 | -- | Networking 2 | module Haskus.System.Network 3 | ( createKernelEventSocket 4 | , receiveKernelEvent 5 | ) 6 | where 7 | 8 | import qualified Haskus.Format.Binary.BitSet as BitSet 9 | import Haskus.System.Linux.KernelEvent 10 | import Haskus.System.Linux.Network 11 | import Haskus.System.Linux.Handle 12 | import Haskus.System.Linux.Network.SendReceive 13 | import Haskus.System.Linux.Internals.Netlink 14 | import Haskus.Utils.Flow 15 | import Haskus.System.Sys 16 | 17 | -- | Create a socket for kernel events 18 | createKernelEventSocket :: Sys Handle 19 | createKernelEventSocket = sysLogSequence "Create kernel event socket" $ do 20 | -- internally the socket is a Netlink socket dedicated to kernel events 21 | fd <- sysSocket (SockTypeNetlink NetlinkTypeKernelEvent) [] 22 | |> logAssertE "Create NetLink socket" 23 | -- bind the socket to any port (i.e. port 0), listen to all multicast groups 24 | sysBindNetlink fd 0 0xFFFFFFFF 25 | |> logAssertE "Bind NetLink socket" 26 | return fd 27 | 28 | 29 | -- | Block until a kernel event is received 30 | receiveKernelEvent :: Handle -> Sys KernelEvent 31 | receiveKernelEvent fd = go 32 | where 33 | go = do 34 | msg <- receiveBuffer fd 2048 BitSet.empty 35 | |> assertE "Receive kernel event" 36 | case parseKernelEvent msg of 37 | Just m -> return m 38 | Nothing -> go -- invalid event received 39 | 40 | 41 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/PCI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | -- | PCI devices 5 | module Haskus.System.PCI 6 | ( pciDevices 7 | , pciClasses 8 | , lookupVendor 9 | , lookupDevice 10 | , lookupSubDevice 11 | , Vendor (..) 12 | , Device (..) 13 | , Class (..) 14 | , SubClass (..) 15 | ) 16 | where 17 | 18 | import Prelude hiding (lookup) 19 | import Data.IntMap.Strict 20 | 21 | import Haskus.System.PCI.MakeTable 22 | import Haskus.System.PCI.Types 23 | import Haskus.Format.Binary.Bits 24 | 25 | -- | List of PCI vendor/device names 26 | [pcis|src/lib/Haskus/System/PCI/pci.ids|] 27 | 28 | -- | Lookup vendor by ID 29 | lookupVendor :: Int -> Maybe Vendor 30 | lookupVendor n = lookup n pciDevices 31 | 32 | -- | Lookup device by ID 33 | lookupDevice :: Vendor -> Int -> Maybe Device 34 | lookupDevice v n = lookup n (vendorDevices v) 35 | 36 | -- | Lookup subdevice by ID 37 | lookupSubDevice :: Device -> Int -> Int -> Maybe String 38 | lookupSubDevice d vendor dev = lookup n (deviceSubDevices d) 39 | where n = (vendor `shiftL` 16) .|. dev 40 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/PCI/Types.hs: -------------------------------------------------------------------------------- 1 | module Haskus.System.PCI.Types 2 | ( Vendor (..) 3 | , Device (..) 4 | , Class (..) 5 | , SubClass (..) 6 | ) 7 | where 8 | 9 | import Data.IntMap.Strict 10 | 11 | data Vendor = Vendor 12 | { vendorName :: String 13 | , vendorDevices :: IntMap Device 14 | } deriving (Show) 15 | 16 | data Device = Device 17 | { deviceName :: String 18 | , deviceSubDevices :: IntMap String 19 | } deriving (Show) 20 | 21 | data Class = Class 22 | { className :: String 23 | , classSubClasses :: IntMap SubClass 24 | } deriving (Show) 25 | 26 | data SubClass = SubClass 27 | { subclassName :: String 28 | , subclassInterfaces :: IntMap String 29 | } deriving (Show) 30 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Posix/Malloc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | 3 | -- | Memory management using Posix API 4 | module Haskus.System.Posix.Malloc 5 | ( malloc 6 | , free 7 | , AllocError(..) 8 | ) 9 | where 10 | 11 | import Foreign.Ptr (Ptr, nullPtr) 12 | import Haskus.Format.Binary.Word 13 | 14 | 15 | -- | Buffer allocation error 16 | data AllocError 17 | = AllocOutOfMemory 18 | | AllocUnknownError 19 | deriving (Show,Eq) 20 | 21 | foreign import ccall unsafe "stdlib.h malloc" malloc_ :: CSize -> IO (Ptr a) 22 | 23 | foreign import ccall unsafe "stdlib.h free" free :: Ptr a -> IO () 24 | 25 | malloc :: CSize -> IO (Either AllocError (Ptr a)) 26 | malloc sz = do 27 | ptr <- malloc_ sz 28 | return $ if ptr == nullPtr && sz /= 0 29 | then Left AllocOutOfMemory 30 | else Right ptr 31 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Power.hs: -------------------------------------------------------------------------------- 1 | -- | Power management 2 | module Haskus.System.Power 3 | ( disableRebootKeys 4 | , enableRebootKeys 5 | , halt 6 | , executeLoadedKernel 7 | , powerOff 8 | , powerOff_ 9 | , restart 10 | , restart_ 11 | , restartWithCommand 12 | , softSuspend 13 | ) 14 | where 15 | 16 | import Haskus.Utils.Flow 17 | import qualified Haskus.System.Linux.Power as L 18 | import Haskus.System.Linux.Error 19 | 20 | -- | Ctrl-Alt-Del sequence sends SIGINT to init task. 21 | disableRebootKeys :: MonadInIO m => m (VEither '[NotAllowed] ()) 22 | disableRebootKeys = runE L.disableRebootKeys 23 | 24 | -- | Ctrl-Alt-Del sequence causes RESTART command. 25 | enableRebootKeys :: MonadInIO m => m (VEither '[NotAllowed] ()) 26 | enableRebootKeys = runE L.enableRebootKeys 27 | 28 | -- | Stop OS and give system control to ROM monitor, if any. 29 | halt :: MonadInIO m => m (VEither '[NotAllowed] ()) 30 | halt = runE L.halt 31 | 32 | -- | Restart system using a previously loaded Linux kernel 33 | executeLoadedKernel :: MonadInIO m => m (VEither '[NotAllowed] ()) 34 | executeLoadedKernel = runE L.executeLoadedKernel 35 | 36 | -- | Stop OS and remove all power from system, if possible. 37 | powerOff :: MonadInIO m => m (VEither '[NotAllowed] ()) 38 | powerOff = runE L.powerOff 39 | 40 | -- | Stop OS and remove all power from system, if possible. 41 | powerOff_ :: MonadInIO m => m () 42 | powerOff_ = void powerOff 43 | 44 | -- | Restart system using default command and mode. 45 | restart :: MonadInIO m => m (VEither '[NotAllowed] ()) 46 | restart = runE L.restart 47 | 48 | -- | Restart system using default command and mode. 49 | restart_ :: MonadInIO m => m () 50 | restart_ = void restart 51 | 52 | -- | Restart system using given command string. 53 | restartWithCommand :: MonadInIO m => String -> m (VEither '[NotAllowed,MemoryError,InvalidRestartCommand] ()) 54 | restartWithCommand cmd = runE (L.restartWithCommand cmd) 55 | 56 | -- | Suspend system using software suspend if compiled in. 57 | softSuspend :: MonadInIO m => m (VEither '[NotAllowed] ()) 58 | softSuspend = runE L.softSuspend 59 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Process.hs: -------------------------------------------------------------------------------- 1 | -- | Process utilities 2 | module Haskus.System.Process 3 | ( threadDelaySec 4 | , threadDelayMilliSec 5 | , threadDelayMicroSec 6 | , threadWaitRead 7 | , threadWaitWrite 8 | , yield 9 | , sysFork 10 | ) 11 | where 12 | 13 | import Haskus.System.Sys 14 | import Haskus.System.Linux.Handle 15 | import Haskus.Utils.Flow 16 | import Haskus.Format.Text (Text) 17 | 18 | import System.Posix.Types (Fd(..)) 19 | import qualified Control.Concurrent as CC 20 | 21 | -- | Delay the thread (seconds) 22 | threadDelaySec :: MonadIO m => Word -> m () 23 | threadDelaySec = threadDelayMicroSec . (*1000000) 24 | 25 | -- | Delay the thread (milliseconds) 26 | threadDelayMilliSec :: MonadIO m => Word -> m () 27 | threadDelayMilliSec = threadDelayMicroSec . (*1000) 28 | 29 | -- | Delay the thread (microseconds) 30 | threadDelayMicroSec :: MonadIO m => Word -> m () 31 | threadDelayMicroSec = liftIO . CC.threadDelay . fromIntegral 32 | 33 | -- | Wait until a handle is readable 34 | threadWaitRead :: MonadIO m => Handle -> m () 35 | threadWaitRead h = liftIO (CC.threadWaitRead (handleToFd h)) 36 | 37 | -- | Wait until a handle is writeable 38 | threadWaitWrite :: MonadIO m => Handle -> m () 39 | threadWaitWrite h = liftIO (CC.threadWaitWrite (handleToFd h)) 40 | 41 | -- | Convert a handle into an Fd 42 | handleToFd :: Handle -> Fd 43 | handleToFd (Handle fd) = Fd (fromIntegral fd) 44 | 45 | -- | Switch to another thread cooperatively 46 | yield :: MonadIO m => m () 47 | yield = liftIO CC.yield 48 | 49 | -- | Fork a thread 50 | sysFork :: Text -> Sys () -> Sys () 51 | sysFork name f = do 52 | act <- forkSys name f 53 | void $ liftIO $ CC.forkIO act 54 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/Process/MemoryMap.hs: -------------------------------------------------------------------------------- 1 | module Haskus.System.Process.MemoryMap 2 | ( module Haskus.System.Linux.Process.MemoryMap 3 | , showProcessMemoryMap 4 | ) 5 | where 6 | 7 | import Haskus.System.Linux.Process.MemoryMap 8 | import Haskus.System.Terminal 9 | import Haskus.System.Sys 10 | import Haskus.Format.Text 11 | import Haskus.Utils.Flow 12 | 13 | showProcessMemoryMap :: Terminal -> [MemoryMapEntry] -> Sys () 14 | showProcessMemoryMap term x = do 15 | writeTextLn term (textFormat 16 | ( (center 25 ' ' %. text) 17 | % " " 18 | % text 19 | % " " 20 | % text 21 | ) 22 | "Memory range" 23 | "Flgs" 24 | "Mapping" 25 | ) 26 | 27 | let hasReadPerm [] = False 28 | hasReadPerm (PermRead:_) = True 29 | hasReadPerm (_:xs) = hasReadPerm xs 30 | 31 | let hasWritePerm [] = False 32 | hasWritePerm (PermWrite:_) = True 33 | hasWritePerm (_:xs) = hasWritePerm xs 34 | 35 | let hasExecPerm [] = False 36 | hasExecPerm (PermExec:_) = True 37 | hasExecPerm (_:xs) = hasExecPerm xs 38 | 39 | forM_ x <| \y -> do 40 | writeTextLn term (textFormat 41 | ((left 12 '0' %. hex) 42 | % "-" 43 | % (left 12 '0' %. hex) 44 | % " " 45 | % char % char % char % char 46 | % " " 47 | % stext 48 | ) 49 | (entryStartAddr y) 50 | (entryStopAddr y) 51 | (if hasReadPerm (entryPerms y) then 'r' else '-') 52 | (if hasWritePerm (entryPerms y) then 'w' else '-') 53 | (if hasExecPerm (entryPerms y) then 'x' else '-') 54 | (case entrySharing y of 55 | Private -> 'p' 56 | Shared -> 's' 57 | ) 58 | (case entryType y of 59 | AnonymousMapping -> "" 60 | NamedMapping s -> textFormat ("[" % stext % "]") s 61 | fm@FileMapping {} -> textFormat (stext % " @ " % hex) 62 | (fileMappingPath fm) 63 | (fileMappingOffset fm) 64 | ) 65 | ) 66 | 67 | -------------------------------------------------------------------------------- /haskus-system/src/lib/Haskus/System/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -- | System 8 | module Haskus.System.System 9 | ( System(..) 10 | , defaultSystemInit 11 | , systemInit 12 | -- * Memory map 13 | , getProcessMemoryMap 14 | , memoryMapToBufferList 15 | , memoryMapToBuffer 16 | , MemoryMapEntry (..) 17 | , MappingType (..) 18 | , Perm (..) 19 | , Sharing (..) 20 | ) 21 | where 22 | 23 | import qualified Haskus.Format.Binary.BitSet as BitSet 24 | import Haskus.System.Linux.ErrorCode 25 | import Haskus.System.Linux.Handle 26 | import Haskus.System.Linux.FileSystem 27 | import Haskus.System.Linux.FileSystem.Directory 28 | import Haskus.System.Linux.FileSystem.ReadWrite 29 | import Haskus.System.Linux.FileSystem.Mount 30 | import Haskus.System.Linux.Process.MemoryMap 31 | 32 | import Haskus.System.Sys 33 | import Haskus.System.FileSystem 34 | import Haskus.System.Devices 35 | import Haskus.Utils.Flow 36 | import Haskus.Utils.Types.List 37 | 38 | import System.FilePath 39 | 40 | import Prelude hiding (init,tail) 41 | 42 | data System = System 43 | { systemProcFS :: Handle -- ^ procfs 44 | , systemDeviceManager :: DeviceManager -- ^ Device manager 45 | } 46 | 47 | -- | Initialize the system 48 | defaultSystemInit :: Sys System 49 | defaultSystemInit = systemInit "/system" 50 | 51 | -- | Create a system object 52 | -- 53 | -- Create the given @path@ if it doesn't exist and mount the system in it 54 | systemInit :: FilePath -> Sys System 55 | systemInit path = sysLogSequence "Initialize the system" $ do 56 | 57 | let 58 | createDir p = sysCreateDirectory Nothing p (BitSet.fromList [PermUserRead,PermUserWrite,PermUserExecute]) False 59 | sysfsPath = path "sys" 60 | procfsPath = path "proc" 61 | devicePath = path "dev" 62 | 63 | -- create root path (allowed to fail if it already exists) 64 | logAssertE "Create root directory" <| do 65 | createDir path `catchLiftLeft` \case 66 | EEXIST -> return () 67 | e -> failureE e 68 | 69 | -- mount a tmpfs in root path 70 | logAssertE "Mount tmpfs" <| mountTmpFS sysMount path 71 | 72 | -- mount sysfs 73 | logAssertE "Create sysfs directory" <| createDir sysfsPath 74 | logAssertE "Mount sysfs" <| mountSysFS sysMount sysfsPath 75 | sysfd <- open Nothing sysfsPath BitSet.empty BitSet.empty 76 | |> logAssertE "open sysfs directory" 77 | 78 | -- mount procfs 79 | logAssertE "Create procfs directory" <| createDir procfsPath 80 | logAssertE "Mount procfs" <| mountProcFS sysMount procfsPath 81 | procfd <- open Nothing procfsPath BitSet.empty BitSet.empty 82 | |> logAssertE "open procfs directory" 83 | 84 | -- create device directory 85 | logAssertE "Create device directory" <| createDir devicePath 86 | logAssertE "Mount tmpfs" <| mountTmpFS sysMount devicePath 87 | devfd <- open Nothing devicePath BitSet.empty BitSet.empty 88 | |> logAssertE "open device directory" 89 | 90 | -- init device manager 91 | dm <- initDeviceManager sysfd devfd 92 | 93 | return $ System 94 | { systemProcFS = procfd 95 | , systemDeviceManager = dm 96 | } 97 | 98 | -- | Get process memory mappings 99 | getProcessMemoryMap :: System -> Excepts (Union ReadErrors' OpenErrors) Sys [MemoryMapEntry] 100 | getProcessMemoryMap sys = 101 | atomicReadBuffer (systemProcFS sys) "self/maps" 102 | ||> parseMemoryMap 103 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests where 2 | 3 | import Test.Tasty 4 | 5 | import Haskus.Tests.Format 6 | import Haskus.Tests.System 7 | import Haskus.Tests.Arch 8 | 9 | tests :: TestTree 10 | tests = testGroup "Tests" $ 11 | [ testsFormat 12 | , testsSystem 13 | , testsArch 14 | ] 15 | 16 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Arch.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Arch where 2 | 3 | import Test.Tasty 4 | 5 | import Haskus.Tests.Arch.Linux 6 | 7 | testsArch :: TestTree 8 | testsArch = testGroup "Arch" 9 | [ testsLinux 10 | ] 11 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Arch/Linux.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Arch.Linux where 2 | 3 | 4 | import Test.Tasty 5 | 6 | import Haskus.Tests.Arch.Linux.Input 7 | import Haskus.Tests.Arch.Linux.ErrorCode 8 | 9 | testsLinux :: TestTree 10 | testsLinux = testGroup "Linux" 11 | [ testsInput 12 | , testsErrorCode 13 | ] 14 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Arch/Linux/ErrorCode.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Arch.Linux.ErrorCode 2 | ( testsErrorCode 3 | ) 4 | where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck as QC 8 | 9 | import Haskus.System.Linux.ErrorCode 10 | import Haskus.Format.Binary.Enum 11 | import Haskus.Format.Binary.Word 12 | 13 | testsErrorCode :: TestTree 14 | testsErrorCode = testGroup "Error codes" 15 | [ testProperty "ErrorCode's enum EBUSY" 16 | (toCEnum (16 :: Word64) == EBUSY) 17 | , testProperty "ErrorCode's enum EDOTDOT" 18 | (toCEnum (73 :: Word64) == EDOTDOT) 19 | , testProperty "ErrorCode's enum ENETDOWN" 20 | (toCEnum (100 :: Word64) == ENETDOWN) 21 | , testProperty "ErrorCode's enum EINPROGRESS" 22 | (toCEnum (115 :: Word64) == EINPROGRESS) 23 | , testProperty "ErrorCode's enum EHWPOISON" 24 | (toCEnum (133 :: Word64) == EHWPOISON) 25 | , testProperty "ErrorCode's enum EOTHER" 26 | (toCEnum (150 :: Word64) == EOTHER 150) 27 | ] 28 | 29 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Arch/Linux/Input.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Arch.Linux.Input 2 | ( testsInput 3 | ) 4 | where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck as QC 8 | 9 | import Haskus.System.Linux.Internals.Input 10 | import Haskus.Format.Binary.Enum 11 | import Haskus.Format.Binary.Word 12 | 13 | testsInput :: TestTree 14 | testsInput = testGroup "Input" 15 | [ testProperty "Key's enum" 16 | (toCEnum (0x270 :: Word16) == NextFavorite) 17 | ] 18 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Common.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Common 2 | ( isBijective 3 | , isEquivalent 4 | , ArbitraryByteString (..) 5 | , ArbitraryByteStringNoNul (..) 6 | , ArbitraryBuffer (..) 7 | , ArbitraryBufferNoNul (..) 8 | ) 9 | where 10 | 11 | 12 | import Test.Tasty.QuickCheck as QC 13 | 14 | import qualified Data.ByteString as BS 15 | 16 | import Haskus.Format.Binary.Buffer 17 | 18 | -- | Ensure a function is bijective 19 | isBijective :: Eq a => (a -> a) -> a -> Bool 20 | isBijective f w = w == (f (f w)) 21 | 22 | -- | Ensure that two functions return the same thing for the same input 23 | isEquivalent :: Eq b => (a -> b) -> (a -> b) -> a -> Bool 24 | isEquivalent f g x = (f x) == (g x) 25 | 26 | -- | Arbitrary ByteString (50 chars long max) 27 | newtype ArbitraryByteString 28 | = ArbitraryByteString BS.ByteString 29 | deriving (Show) 30 | 31 | instance Arbitrary ArbitraryByteString where 32 | arbitrary = ArbitraryByteString . BS.pack <$> resize 50 (listOf arbitrary) 33 | shrink (ArbitraryByteString bs) 34 | | BS.null bs = [] 35 | | otherwise = [ArbitraryByteString $ BS.take (BS.length bs `div` 2) bs] 36 | 37 | -- | Arbitrary ByteString (50 chars long max, no Nul) 38 | newtype ArbitraryByteStringNoNul 39 | = ArbitraryByteStringNoNul BS.ByteString 40 | deriving (Show) 41 | 42 | instance Arbitrary ArbitraryByteStringNoNul where 43 | arbitrary = ArbitraryByteStringNoNul . BS.pack <$> resize 50 (listOf (choose (1,255))) -- we exclude 0 44 | shrink (ArbitraryByteStringNoNul bs) 45 | | BS.null bs = [] 46 | | otherwise = [ArbitraryByteStringNoNul $ BS.take (BS.length bs `div` 2) bs] 47 | 48 | -- | Arbitrary Buffer (50 chars long max) 49 | newtype ArbitraryBuffer 50 | = ArbitraryBuffer Buffer 51 | deriving (Show) 52 | 53 | instance Arbitrary ArbitraryBuffer where 54 | arbitrary = do 55 | ArbitraryByteString bs <- arbitrary 56 | return (ArbitraryBuffer (Buffer bs)) 57 | 58 | shrink (ArbitraryBuffer bs) 59 | | isBufferEmpty bs = [] 60 | | otherwise = [ArbitraryBuffer $ bufferTake (bufferSize bs `div` 2) bs] 61 | 62 | -- | Arbitrary Buffer (50 chars long max, no Nul) 63 | newtype ArbitraryBufferNoNul 64 | = ArbitraryBufferNoNul Buffer 65 | deriving (Show) 66 | 67 | instance Arbitrary ArbitraryBufferNoNul where 68 | arbitrary = do 69 | ArbitraryByteStringNoNul bs <- arbitrary 70 | return (ArbitraryBufferNoNul (Buffer bs)) 71 | shrink (ArbitraryBufferNoNul bs) 72 | | isBufferEmpty bs = [] 73 | | otherwise = [ArbitraryBufferNoNul $ bufferTake (bufferSize bs `div` 2) bs] 74 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/Format.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.Format where 2 | 3 | import Test.Tasty 4 | 5 | testsFormat :: TestTree 6 | testsFormat = testGroup "Format" 7 | [ 8 | ] 9 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/System.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.System where 2 | 3 | import Test.Tasty 4 | 5 | import Haskus.Tests.System.Devices 6 | 7 | testsSystem :: TestTree 8 | testsSystem = testGroup "System" 9 | [ testsDevices 10 | ] 11 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Haskus/Tests/System/Devices.hs: -------------------------------------------------------------------------------- 1 | module Haskus.Tests.System.Devices 2 | ( testsDevices 3 | ) 4 | where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck as QC 8 | import Test.QuickCheck.Monadic 9 | 10 | import qualified Haskus.Format.Text as Text 11 | import Haskus.System.Devices 12 | 13 | import Data.Maybe 14 | import qualified Data.Map as Map 15 | import Control.Concurrent.STM 16 | 17 | 18 | treeRoot :: IO DeviceTree 19 | treeRoot = deviceTreeCreate Nothing Nothing Map.empty 20 | 21 | treeXYZ :: IO DeviceTree 22 | treeXYZ = deviceTreeCreate (Just (Text.pack "XYZ")) Nothing Map.empty 23 | 24 | treeABC :: IO DeviceTree 25 | treeABC = deviceTreeCreate (Just (Text.pack "ABC")) Nothing Map.empty 26 | 27 | testsDevices :: TestTree 28 | testsDevices = testGroup "Device tree" 29 | [ testProperty "Insert/lookup" $ monadicIO $ do 30 | let path = Text.pack "/devices/xyz" 31 | tree <- run $ do 32 | s <- deviceTreeInsert path <$> treeXYZ <*> treeRoot 33 | atomically s 34 | let xyz = deviceTreeLookup path tree 35 | assert (isJust xyz) 36 | assert (deviceNodeSubsystem (fromJust xyz) == Just (Text.pack "XYZ")) 37 | 38 | , testProperty "Insert/remove" $ monadicIO $ do 39 | let path = Text.pack "/devices/xyz" 40 | tree <- run $ do 41 | s <- deviceTreeInsert path <$> treeXYZ <*> treeRoot 42 | atomically s 43 | let xyz = deviceTreeLookup path (deviceTreeRemove path tree) 44 | assert (isNothing xyz) 45 | 46 | , testProperty "Insert/lookup hierarchy" $ monadicIO $ do 47 | let path0 = Text.pack "/devices/xyz" 48 | let path1 = Text.pack "/devices/xyz/abc" 49 | tree <- run $ do 50 | xyz <- treeXYZ 51 | abc <- treeABC 52 | root <- treeRoot 53 | atomically $ do 54 | t1 <- deviceTreeInsert path0 xyz root 55 | deviceTreeInsert path1 abc t1 56 | let abc = deviceTreeLookup path1 tree 57 | assert (isJust abc) 58 | assert (deviceNodeSubsystem (fromJust abc) == Just (Text.pack "ABC")) 59 | 60 | ] 61 | -------------------------------------------------------------------------------- /haskus-system/src/tests/Main.hs: -------------------------------------------------------------------------------- 1 | import Haskus.Tests 2 | import Test.Tasty 3 | 4 | main :: IO () 5 | main = defaultMain tests 6 | -------------------------------------------------------------------------------- /manage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | dirs=$(ls -d haskus-*/ | cut -d'/' -f1) 3 | 4 | function last_tag { 5 | git tag -l | grep "$1-[0-9]" | sort -r -V | head -n 1 6 | } 7 | 8 | function check_tag { 9 | local t=$(git tag -l | grep "$1") 10 | if [ "$t" = "" ] 11 | then echo "NO" 12 | else echo "YES" 13 | fi 14 | } 15 | 16 | function is_uploaded { 17 | local v=$(curl -s -I https://hackage.haskell.org/package/$1 | head -n 1 | cut -d' ' -f2) 18 | if [ "$v" = "200" ] 19 | then echo "YES" 20 | else if [ "$v" = "404" ] 21 | then echo "NO" 22 | else echo "DON'T KNOW" 23 | fi 24 | fi 25 | } 26 | 27 | function package_version { 28 | ver=$(cd $1 && stack query locals $1 version) 29 | echo $ver | cut -d"'" -f2 30 | } 31 | 32 | function report { 33 | tag=$(last_tag $1) 34 | echo "" 35 | echo "---------------------------------------------------------------" 36 | echo "$1:" 37 | echo " - Last tag: $tag" 38 | echo " - Last tag hackage uploaded: $(is_uploaded $tag)" 39 | echo " - Dev version: $(package_version $1)" 40 | echo " - Log since last tag:" 41 | git --no-pager log --oneline $tag..HEAD -- $1/ 42 | echo "---------------------------------------------------------------" 43 | } 44 | 45 | function report_all { 46 | echo "===============================================================" 47 | echo "Reporting package infos" 48 | echo "===============================================================" 49 | for i in $dirs 50 | do 51 | report $i 52 | done 53 | } 54 | 55 | function build { 56 | echo "===============================================================" 57 | echo "Building $1" 58 | echo "===============================================================" 59 | 60 | result=$(cd $1 && stack clean && stack test) 61 | if [ $? -ne 0 ] 62 | then echo "Error! Fix it and press a key. " && read -n 1 -s && build $1 63 | fi 64 | echo $result 65 | } 66 | 67 | function build_all { 68 | for i in $dirs 69 | do 70 | build $i 71 | done 72 | } 73 | 74 | function showdone { 75 | echo "" 76 | echo "===============================================================" 77 | echo "Done" 78 | echo "===============================================================" 79 | } 80 | 81 | function check_dev_version { 82 | echo "Package: $1" 83 | local v="$(package_version $1)" 84 | echo " - Version: $v" 85 | local nt="$1-$v" 86 | local upl=$(is_uploaded $nt) 87 | echo " - Already on Hackage: $upl" 88 | local ct=$(check_tag $nt) 89 | echo " - Tag exist: $ct" 90 | if [ "$ct" = "NO" ] 91 | then echo "You need to create the tag $nt" && exit 1 92 | fi 93 | } 94 | 95 | function check_dev_versions { 96 | echo "===============================================================" 97 | echo "Checking release versions" 98 | echo "===============================================================" 99 | for i in $dirs 100 | do 101 | check_dev_version $i 102 | done 103 | } 104 | 105 | function check_rep_state { 106 | echo "===============================================================" 107 | echo "Checking repository state" 108 | echo "===============================================================" 109 | 110 | local r=$(git status -s --untracked-files=no) 111 | if [ "$r" != "" ] 112 | then echo "Repository isn't clean:" && git status && exit 1 113 | else echo "Repositry is clean" 114 | fi 115 | } 116 | 117 | case "$1" in 118 | report) 119 | report_all 120 | showdone 121 | ;; 122 | check) 123 | check_dev_versions 124 | showdone 125 | ;; 126 | build) 127 | build_all 128 | showdone 129 | ;; 130 | release) 131 | check_dev_versions 132 | check_rep_state 133 | report_all 134 | build_all 135 | showdone 136 | ;; 137 | *) 138 | echo "Missing command: check, report, build, release" 139 | exit 0 140 | esac 141 | -------------------------------------------------------------------------------- /scripts/json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | import Data.Aeson 10 | import GHC.Generics 11 | import Haskus.Utils.Variant 12 | 13 | ------------- Boilerplate -------------- 14 | class ToJSON' x where 15 | toJSON' :: Int -> x -> Value 16 | 17 | instance ToJSON' (Variant '[]) where 18 | toJSON' = undefined 19 | 20 | instance 21 | ( ToJSON' (Variant ts) 22 | , ToJSON t 23 | ) => ToJSON' (Variant (t ': ts)) 24 | where 25 | toJSON' n v = case headVariant v of 26 | Right t -> toJSON (n,t) 27 | Left ts -> toJSON' (n+1) ts 28 | 29 | instance ToJSON' (Variant ts) => ToJSON (Variant ts) where 30 | toJSON = toJSON' 0 31 | 32 | ------------- End boilerplate -------------- 33 | 34 | 35 | data Foo = Foo Int Int deriving (Show, Generic, FromJSON, ToJSON) 36 | data Bar = Bar Int Int deriving (Show, Generic, FromJSON, ToJSON) 37 | data Baz = Baz String deriving (Show, Generic, FromJSON, ToJSON) 38 | 39 | type T = Variant '[Foo,Bar,Baz] 40 | 41 | main :: IO () 42 | main = do 43 | let 44 | t0 = setVariant (Foo 42 43) :: T 45 | t1 = setVariant (Bar 42 43) :: T 46 | t2 = setVariant (Baz "Test") :: T 47 | print (encode t0) 48 | print (encode t1) 49 | print (encode t2) 50 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.10 2 | packages: 3 | - 'haskus-system' 4 | - 'haskus-system-build' 5 | - 'haskus-system-tools' 6 | 7 | extra-deps: 8 | # - haskus-utils-variant-2.6.1 9 | # - haskus-utils-1.4 10 | # - haskus-utils-data-1.1.1 11 | # - haskus-utils-types-1.4.1 12 | # - haskus-binary-1.4 13 | - haskus-utils-compat-1.0 14 | - stm-containers-1.1.0.2 15 | - stm-hamt-1.2.0.2 16 | - primitive-extras-0.7.1 17 | - happstack-server-7.5.1.3 18 | - git: https://github.com/haskus/packages.git 19 | commit: 5f15ae97eb0a07b06739f999c1fd7e223e04f23e 20 | subdirs: 21 | - haskus-utils-variant 22 | - haskus-utils 23 | - haskus-utils-types 24 | - haskus-utils-data 25 | - haskus-binary 26 | 27 | flags: 28 | diagrams: 29 | rasterific: true 30 | 31 | extra-package-dbs: [] 32 | 33 | ghc-options: 34 | "$locals": -fhide-source-paths -freverse-errors 35 | "haskus-system": -fobject-code 36 | # -fobject-code -- GHCI needs it because of the foreign primops 37 | --------------------------------------------------------------------------------