Compare commits
68 Commits
docfix
...
developmen
| Author | SHA1 | Date | |
|---|---|---|---|
| a25f92e4ec | |||
| 4254c80a64 | |||
| ca9cf51e3c | |||
| 29f4dc67b6 | |||
| a91b4859d0 | |||
| c89d6b945c | |||
| 5b6a342a9e | |||
| 8646a6338c | |||
| db16dcbb5d | |||
| 3af8b36940 | |||
| 9c6cf51825 | |||
| d58fd6e6f0 | |||
| 1487351f29 | |||
| e56c345156 | |||
| 37773383af | |||
| 8b0e59faa7 | |||
| 6ec455b515 | |||
| 4a86b4d2cf | |||
| 70270d60ba | |||
| bd70b8751a | |||
| 31fe08195f | |||
| c84512e3b3 | |||
| 9a11e35be0 | |||
| 7e8d465d81 | |||
| 526db2cbb7 | |||
| 5670b160d8 | |||
| ac41b053e3 | |||
| 37516306d3 | |||
| 71cee4019b | |||
| 94bcc12224 | |||
| 782abe2584 | |||
| 3e5777bf3a | |||
| c76c27288d | |||
| 98e8104602 | |||
| 95b49f41dd | |||
| b3b239d4c9 | |||
| c5afe976cf | |||
| f48c3ecfe4 | |||
| ce1383dc11 | |||
| 47cd43dba6 | |||
|
|
1be9ecb44e | ||
| 251a20e881 | |||
| c29693fbd0 | |||
| 9420af15a1 | |||
| 3008e4463b | |||
|
|
44fc047223 | ||
|
|
8348f34a4a | ||
| a4c8995299 | |||
| 0ff24002e5 | |||
| 7608d838aa | |||
| d432c2146b | |||
| 064d5a1032 | |||
| 39bc0cba24 | |||
| 07c5fa2d62 | |||
| 5c57551438 | |||
| 3c6aca04b4 | |||
| 9d572c8a6e | |||
| 680a75f5be | |||
| 4b0e3ba89a | |||
| 02f04d92f3 | |||
| a61b409486 | |||
| a7ba20ae00 | |||
| 9b43814846 | |||
| 8b8c9a669f | |||
| 7f538f4fae | |||
| 1d2bf37a44 | |||
| 2e16e0ae48 | |||
| 260e7ea01c |
3
.gitmodules
vendored
3
.gitmodules
vendored
@@ -1,9 +1,6 @@
|
|||||||
[submodule "3rdparty/hpath"]
|
[submodule "3rdparty/hpath"]
|
||||||
path = 3rdparty/hpath
|
path = 3rdparty/hpath
|
||||||
url = https://github.com/hasufell/hpath.git
|
url = https://github.com/hasufell/hpath.git
|
||||||
[submodule "3rdparty/hinotify"]
|
|
||||||
path = 3rdparty/hinotify
|
|
||||||
url = https://github.com/hasufell/hinotify.git
|
|
||||||
[submodule "3rdparty/simple-sendfile"]
|
[submodule "3rdparty/simple-sendfile"]
|
||||||
path = 3rdparty/simple-sendfile
|
path = 3rdparty/simple-sendfile
|
||||||
url = https://github.com/hasufell/simple-sendfile.git
|
url = https://github.com/hasufell/simple-sendfile.git
|
||||||
|
|||||||
1
3rdparty/hinotify
vendored
1
3rdparty/hinotify
vendored
Submodule 3rdparty/hinotify deleted from 6751bf0cc8
2
3rdparty/hpath
vendored
2
3rdparty/hpath
vendored
Submodule 3rdparty/hpath updated: a5360f29a3...1263fac7ec
1
HACKING.md
Symbolic link
1
HACKING.md
Symbolic link
@@ -0,0 +1 @@
|
|||||||
|
hacking/HACKING.md
|
||||||
10
README.md
10
README.md
@@ -15,12 +15,20 @@ Design goals:
|
|||||||
Screenshots
|
Screenshots
|
||||||
-----------
|
-----------
|
||||||
|
|
||||||

|

|
||||||
|
|
||||||
Installation
|
Installation
|
||||||
------------
|
------------
|
||||||
|
|
||||||
```
|
```
|
||||||
|
git submodule update --init --recursive
|
||||||
|
cabal sandbox init
|
||||||
|
cabal sandbox add-source 3rdparty/hpath
|
||||||
|
cabal sandbox add-source 3rdparty/hpath/3rdparty/posix-paths
|
||||||
|
cabal sandbox add-source 3rdparty/simple-sendfile
|
||||||
|
cabal install alex happy
|
||||||
|
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
|
||||||
|
cabal install gtk2hs-buildtools
|
||||||
cabal install
|
cabal install
|
||||||
```
|
```
|
||||||
|
|
||||||
|
|||||||
@@ -2,113 +2,281 @@
|
|||||||
<!-- Generated with glade 3.18.3 -->
|
<!-- Generated with glade 3.18.3 -->
|
||||||
<interface>
|
<interface>
|
||||||
<requires lib="gtk+" version="3.16"/>
|
<requires lib="gtk+" version="3.16"/>
|
||||||
|
<object class="GtkGrid" id="fpropGrid">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="row_spacing">2</property>
|
||||||
|
<property name="column_spacing">2</property>
|
||||||
|
<property name="row_homogeneous">True</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label1">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">File Name:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropFnEntry">
|
||||||
|
<property name="width_request">350</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Location:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label3">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Total Size:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">2</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropLocEntry">
|
||||||
|
<property name="width_request">350</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropTsEntry">
|
||||||
|
<property name="width_request">350</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">2</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label5">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Accessed:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">7</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label4">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Modified:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">6</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropModEntry">
|
||||||
|
<property name="width_request">350</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">6</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropAcEntry">
|
||||||
|
<property name="width_request">350</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">7</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label6">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">File Type:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">3</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropFTEntry">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">3</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropPermEntry">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">4</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label7">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Link Destination:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">5</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkLabel" id="label8">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="halign">start</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="label" translatable="yes">Permissions:</property>
|
||||||
|
<attributes>
|
||||||
|
<attribute name="weight" value="bold"/>
|
||||||
|
</attributes>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">0</property>
|
||||||
|
<property name="top_attach">4</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="fpropLDEntry">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="margin_left">5</property>
|
||||||
|
<property name="margin_right">5</property>
|
||||||
|
<property name="margin_top">2</property>
|
||||||
|
<property name="margin_bottom">2</property>
|
||||||
|
<property name="editable">False</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="left_attach">1</property>
|
||||||
|
<property name="top_attach">5</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
<object class="GtkImage" id="image1">
|
<object class="GtkImage" id="image1">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<property name="stock">gtk-edit</property>
|
<property name="stock">gtk-edit</property>
|
||||||
</object>
|
</object>
|
||||||
<object class="GtkMenu" id="rcMenu">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileOpen">
|
|
||||||
<property name="label">gtk-open</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileExecute">
|
|
||||||
<property name="label">gtk-execute</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileNew">
|
|
||||||
<property name="label">gtk-new</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileCut">
|
|
||||||
<property name="label">gtk-cut</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileCopy">
|
|
||||||
<property name="label">gtk-copy</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileRename">
|
|
||||||
<property name="label">Rename</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="image">image1</property>
|
|
||||||
<property name="use_stock">False</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFilePaste">
|
|
||||||
<property name="label">gtk-paste</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="rcFileDelete">
|
|
||||||
<property name="label">gtk-delete</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
</object>
|
|
||||||
<object class="GtkImage" id="image2">
|
<object class="GtkImage" id="image2">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<property name="stock">gtk-edit</property>
|
<property name="stock">gtk-open</property>
|
||||||
</object>
|
</object>
|
||||||
<object class="GtkImage" id="image3">
|
<object class="GtkImage" id="image3">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<property name="stock">gtk-cancel</property>
|
<property name="stock">gtk-cancel</property>
|
||||||
</object>
|
</object>
|
||||||
<object class="GtkImage" id="image4">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="stock">gtk-zoom-fit</property>
|
|
||||||
</object>
|
|
||||||
<object class="GtkImage" id="image5">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="stock">gtk-zoom-fit</property>
|
|
||||||
</object>
|
|
||||||
<object class="GtkApplicationWindow" id="rootWin">
|
<object class="GtkApplicationWindow" id="rootWin">
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<child>
|
<child>
|
||||||
@@ -130,33 +298,6 @@
|
|||||||
<object class="GtkMenu" id="menu1">
|
<object class="GtkMenu" id="menu1">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarFileOpen">
|
|
||||||
<property name="label">gtk-open</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarFileExecute">
|
|
||||||
<property name="label">gtk-execute</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarFileNew">
|
|
||||||
<property name="label">gtk-new</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
<child>
|
||||||
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
|
<object class="GtkSeparatorMenuItem" id="separatormenuitem1">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
@@ -176,65 +317,6 @@
|
|||||||
</child>
|
</child>
|
||||||
</object>
|
</object>
|
||||||
</child>
|
</child>
|
||||||
<child>
|
|
||||||
<object class="GtkMenuItem" id="menubarEdit">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="label" translatable="yes">_Edit</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<child type="submenu">
|
|
||||||
<object class="GtkMenu" id="menu2">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarEditCut">
|
|
||||||
<property name="label">gtk-cut</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarEditCopy">
|
|
||||||
<property name="label">gtk-copy</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarEditRename">
|
|
||||||
<property name="label">Move</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="image">image2</property>
|
|
||||||
<property name="use_stock">False</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarEditPaste">
|
|
||||||
<property name="label">gtk-paste</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarEditDelete">
|
|
||||||
<property name="label">gtk-delete</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="use_underline">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
<child>
|
||||||
<object class="GtkMenuItem" id="menubarView">
|
<object class="GtkMenuItem" id="menubarView">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
@@ -244,24 +326,6 @@
|
|||||||
<object class="GtkMenu" id="menu5">
|
<object class="GtkMenu" id="menu5">
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">False</property>
|
<property name="can_focus">False</property>
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarViewTree">
|
|
||||||
<property name="label">Tree View</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="image">image4</property>
|
|
||||||
<property name="use_stock">False</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkImageMenuItem" id="menubarViewIcon">
|
|
||||||
<property name="label">Icon view</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<property name="image">image5</property>
|
|
||||||
<property name="use_stock">False</property>
|
|
||||||
</object>
|
|
||||||
</child>
|
|
||||||
</object>
|
</object>
|
||||||
</child>
|
</child>
|
||||||
</object>
|
</object>
|
||||||
@@ -297,82 +361,27 @@
|
|||||||
</packing>
|
</packing>
|
||||||
</child>
|
</child>
|
||||||
<child>
|
<child>
|
||||||
<object class="GtkBox" id="box2">
|
<object class="GtkNotebook" id="notebook">
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">False</property>
|
|
||||||
<child>
|
|
||||||
<object class="GtkEntry" id="urlBar">
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">True</property>
|
|
||||||
<property name="input_purpose">url</property>
|
|
||||||
</object>
|
|
||||||
<packing>
|
|
||||||
<property name="expand">True</property>
|
|
||||||
<property name="fill">True</property>
|
|
||||||
<property name="position">0</property>
|
|
||||||
</packing>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkButton" id="upViewB">
|
|
||||||
<property name="label">gtk-go-up</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">True</property>
|
|
||||||
<property name="receives_default">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
<packing>
|
|
||||||
<property name="expand">False</property>
|
|
||||||
<property name="fill">True</property>
|
|
||||||
<property name="padding">2</property>
|
|
||||||
<property name="position">1</property>
|
|
||||||
</packing>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkButton" id="homeViewB">
|
|
||||||
<property name="label">gtk-home</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">True</property>
|
|
||||||
<property name="receives_default">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
<packing>
|
|
||||||
<property name="expand">False</property>
|
|
||||||
<property name="fill">True</property>
|
|
||||||
<property name="position">2</property>
|
|
||||||
</packing>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkButton" id="refreshViewB">
|
|
||||||
<property name="label">gtk-refresh</property>
|
|
||||||
<property name="visible">True</property>
|
|
||||||
<property name="can_focus">True</property>
|
|
||||||
<property name="receives_default">True</property>
|
|
||||||
<property name="use_stock">True</property>
|
|
||||||
</object>
|
|
||||||
<packing>
|
|
||||||
<property name="expand">False</property>
|
|
||||||
<property name="fill">True</property>
|
|
||||||
<property name="padding">2</property>
|
|
||||||
<property name="position">3</property>
|
|
||||||
</packing>
|
|
||||||
</child>
|
|
||||||
</object>
|
|
||||||
<packing>
|
|
||||||
<property name="expand">False</property>
|
|
||||||
<property name="fill">True</property>
|
|
||||||
<property name="position">1</property>
|
|
||||||
</packing>
|
|
||||||
</child>
|
|
||||||
<child>
|
|
||||||
<object class="GtkScrolledWindow" id="mainScroll">
|
|
||||||
<property name="width_request">300</property>
|
|
||||||
<property name="height_request">500</property>
|
|
||||||
<property name="visible">True</property>
|
<property name="visible">True</property>
|
||||||
<property name="can_focus">True</property>
|
<property name="can_focus">True</property>
|
||||||
<property name="shadow_type">in</property>
|
|
||||||
<child>
|
<child>
|
||||||
<placeholder/>
|
<placeholder/>
|
||||||
</child>
|
</child>
|
||||||
|
<child type="tab">
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
|
<child type="tab">
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
|
<child type="tab">
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
</object>
|
</object>
|
||||||
<packing>
|
<packing>
|
||||||
<property name="expand">True</property>
|
<property name="expand">True</property>
|
||||||
@@ -430,4 +439,267 @@
|
|||||||
</object>
|
</object>
|
||||||
</child>
|
</child>
|
||||||
</object>
|
</object>
|
||||||
|
<object class="GtkImage" id="image4">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="stock">gtk-zoom-in</property>
|
||||||
|
</object>
|
||||||
|
<object class="GtkImage" id="image5">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="stock">gtk-zoom-out</property>
|
||||||
|
</object>
|
||||||
|
<object class="GtkImage" id="image6">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="stock">gtk-directory</property>
|
||||||
|
</object>
|
||||||
|
<object class="GtkImage" id="image7">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="stock">gtk-zoom-fit</property>
|
||||||
|
</object>
|
||||||
|
<object class="GtkMenu" id="rcMenu">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileOpen">
|
||||||
|
<property name="label">gtk-open</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileExecute">
|
||||||
|
<property name="label">gtk-execute</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileNew">
|
||||||
|
<property name="label">gtk-new</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
<child type="submenu">
|
||||||
|
<object class="GtkMenu" id="menu6">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileNewRegFile">
|
||||||
|
<property name="label">gtk-file</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileNewDir">
|
||||||
|
<property name="label" translatable="yes">directory</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="image">image6</property>
|
||||||
|
<property name="use_stock">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileCut">
|
||||||
|
<property name="label">gtk-cut</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileCopy">
|
||||||
|
<property name="label">gtk-copy</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileRename">
|
||||||
|
<property name="label">Rename</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="image">image1</property>
|
||||||
|
<property name="use_stock">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFilePaste">
|
||||||
|
<property name="label">gtk-paste</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileDelete">
|
||||||
|
<property name="label">gtk-delete</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileProperty">
|
||||||
|
<property name="label">gtk-properties</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="use_underline">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkSeparatorMenuItem" id="separatormenuitem3">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileView">
|
||||||
|
<property name="label">View</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="image">image7</property>
|
||||||
|
<property name="use_stock">False</property>
|
||||||
|
<child type="submenu">
|
||||||
|
<object class="GtkMenu" id="menu2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileIconView">
|
||||||
|
<property name="label">icon view</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="image">image4</property>
|
||||||
|
<property name="use_stock">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkImageMenuItem" id="rcFileTreeView">
|
||||||
|
<property name="label" translatable="yes">tree view</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="image">image5</property>
|
||||||
|
<property name="use_stock">False</property>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
<object class="GtkBox" id="viewBox">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<property name="orientation">vertical</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkBox" id="box2">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">False</property>
|
||||||
|
<child>
|
||||||
|
<object class="GtkEntry" id="urlBar">
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="input_purpose">url</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkButton" id="upViewB">
|
||||||
|
<property name="label">gtk-go-up</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="receives_default">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">False</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="padding">2</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkButton" id="homeViewB">
|
||||||
|
<property name="label">gtk-home</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="receives_default">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">False</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">2</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkButton" id="refreshViewB">
|
||||||
|
<property name="label">gtk-refresh</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="receives_default">True</property>
|
||||||
|
<property name="use_stock">True</property>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">False</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="padding">2</property>
|
||||||
|
<property name="position">3</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">False</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">0</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
<child>
|
||||||
|
<object class="GtkScrolledWindow" id="mainScroll">
|
||||||
|
<property name="width_request">300</property>
|
||||||
|
<property name="height_request">500</property>
|
||||||
|
<property name="visible">True</property>
|
||||||
|
<property name="can_focus">True</property>
|
||||||
|
<property name="shadow_type">in</property>
|
||||||
|
<child>
|
||||||
|
<placeholder/>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
|
<packing>
|
||||||
|
<property name="expand">True</property>
|
||||||
|
<property name="fill">True</property>
|
||||||
|
<property name="position">1</property>
|
||||||
|
</packing>
|
||||||
|
</child>
|
||||||
|
</object>
|
||||||
</interface>
|
</interface>
|
||||||
|
|||||||
@@ -1,25 +1,23 @@
|
|||||||
HACKING
|
# HACKING
|
||||||
=======
|
|
||||||
|
|
||||||
Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
|
Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
|
||||||
if you don't know yet what you want to hack on.
|
if you don't know yet what you want to hack on.
|
||||||
|
|
||||||
Coding style
|
## Coding style
|
||||||
------------
|
|
||||||
|
|
||||||
- match the sorroundings
|
- match the sorroundings
|
||||||
- no overcomplicated pointfree style
|
- no overcomplicated pointfree style
|
||||||
- normal indenting 2 whitespaces
|
- normal indenting 2 whitespaces
|
||||||
- just make things pretty and readable
|
- just make things pretty and readable
|
||||||
- use the provided [hsimport.hs](hsimport.hs)
|
- you can use the provided [hsimport.hs](hsimport.hs)
|
||||||
|
|
||||||
Documentation
|
## Documentation
|
||||||
-------------
|
|
||||||
|
|
||||||
__Everything__ must be documented. :)
|
__Everything__ must be documented. :)
|
||||||
|
Don't assume people know what you mean. Type signatures are not sufficient
|
||||||
|
documentation.
|
||||||
|
|
||||||
Hacking Guide
|
## Hacking Overview
|
||||||
-------------
|
|
||||||
|
|
||||||
The main data structure for the IO related File type is in
|
The main data structure for the IO related File type is in
|
||||||
[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
|
[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
|
||||||
@@ -28,6 +26,8 @@ should be seen as a library. This is the entry point where
|
|||||||
and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
|
and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
|
||||||
The File type uses a safe Path type under the hood instead of Strings,
|
The File type uses a safe Path type under the hood instead of Strings,
|
||||||
utilizing the [hpath](https://github.com/hasufell/hpath) library.
|
utilizing the [hpath](https://github.com/hasufell/hpath) library.
|
||||||
|
Note that mostly only absolute paths are allowed on type level to improve
|
||||||
|
path and thread safety.
|
||||||
|
|
||||||
File operations (like copy, delete etc) are defined at
|
File operations (like copy, delete etc) are defined at
|
||||||
[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
|
[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
|
||||||
@@ -52,3 +52,73 @@ following files:
|
|||||||
* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
|
* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
|
||||||
* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
|
* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
|
||||||
|
|
||||||
|
## Concepts
|
||||||
|
|
||||||
|
### Path safety
|
||||||
|
|
||||||
|
Paths are usually represented in haskell libraries as `type FilePath = String`.
|
||||||
|
This is bad, because of a number of reasons:
|
||||||
|
* encoding issues, since the low-level representation of filepaths is in fact an array of C chars
|
||||||
|
* weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings
|
||||||
|
* no information about any property at type level (e.g. is it an absolute path?)
|
||||||
|
* no filepath constructors that do sanity checks and proper parsing
|
||||||
|
* no guarantee whether the filepath is normalised or not or even valid
|
||||||
|
|
||||||
|
Because of that, the solution is:
|
||||||
|
* use `ByteString` under the hood
|
||||||
|
* wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename)
|
||||||
|
* construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path
|
||||||
|
|
||||||
|
This leads to the following benefits:
|
||||||
|
* we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety
|
||||||
|
* we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out
|
||||||
|
* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
|
||||||
|
* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
|
||||||
|
|
||||||
|
The only problem with this approach is that most libraries are still String
|
||||||
|
based. Some provide dedicated `Foo.ByteString` modules though, but it
|
||||||
|
might be necessary to fork libraries.
|
||||||
|
We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath).
|
||||||
|
|
||||||
|
Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless
|
||||||
|
they are filenames (`Path Fn`) and processed for GUI purposes. This is as
|
||||||
|
already mentioned for the purpose of runtime safety, predictability and
|
||||||
|
thread safety.
|
||||||
|
|
||||||
|
### File IO safety
|
||||||
|
|
||||||
|
This is a pretty difficult problem. One thing to ensure safety on IO level
|
||||||
|
is simply the strong haskell type system, since we push everything
|
||||||
|
into our `File a` type and can then pattern match easily against the different
|
||||||
|
types of files.
|
||||||
|
|
||||||
|
The only problem with this approach is that we are examining a file at point
|
||||||
|
`a` in time, safe the information and then use that information further down
|
||||||
|
the call stack at point `b` in time, when the file information in memory
|
||||||
|
could already be out of date. There are two approaches to make this less
|
||||||
|
sucky:
|
||||||
|
* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
|
||||||
|
* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized via `runFileOp`, then the file at the given path is read and the copy/move/whatnot function carried out immediately
|
||||||
|
|
||||||
|
This means we should only interact with the `HSFM.FileSystem.FileOperation`
|
||||||
|
module via the operation data types `FileOperation`, `Copy` and `Move` and
|
||||||
|
the `runFileOp` function. This doesn't completely solve the problem, but for
|
||||||
|
the rest we have to trust the posix functions to throw the proper exceptions.
|
||||||
|
|
||||||
|
In addition, we don't use the `directory` package, which is dangerous
|
||||||
|
and broken. Instead, we implement our own low-level wrappers around
|
||||||
|
the posix functions, so we have proper control over the internals
|
||||||
|
and know the possible exceptions.
|
||||||
|
|
||||||
|
### Exception handling
|
||||||
|
|
||||||
|
Exceptions are good. We don't want to wrap everything in Maybe/Either types
|
||||||
|
unless we want to handle failure immediately. Otherwise we need to make
|
||||||
|
sure that at least at some point IOExceptions are caught and visualized
|
||||||
|
to the user. This is often done via e.g. `withErrorDialog` which catches
|
||||||
|
`IOException` and `FmIOException`.
|
||||||
|
|
||||||
|
It's also important to clean up stuff like filedescriptors via
|
||||||
|
functions like `bracket` directly in our low-level code in case
|
||||||
|
something goes wrong.
|
||||||
|
|
||||||
|
|||||||
@@ -8,7 +8,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
|||||||
where
|
where
|
||||||
prettyPrint :: HS.ImportDecl -> String
|
prettyPrint :: HS.ImportDecl -> String
|
||||||
prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
|
prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
|
||||||
"import " ++ (ifStr qual "qualified") ++
|
"import " ++ (ifStr qual "qualified ") ++
|
||||||
(maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++
|
(maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++
|
||||||
getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
|
getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
|
||||||
specprint mspec
|
specprint mspec
|
||||||
@@ -16,9 +16,9 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
|||||||
specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
|
specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
|
||||||
specprint Nothing = ""
|
specprint Nothing = ""
|
||||||
specprint (Just (False, xs))
|
specprint (Just (False, xs))
|
||||||
= "\n (\n" ++ printImportSpecs xs ++ "\n )"
|
= "\n (\n" ++ printImportSpecs xs ++ " )"
|
||||||
specprint (Just (True, xs))
|
specprint (Just (True, xs))
|
||||||
= "\n hiding (\n" ++ printImportSpecs xs ++ "\n )"
|
= "\n hiding (\n" ++ printImportSpecs xs ++ " )"
|
||||||
|
|
||||||
printImportSpecs :: [HS.ImportSpec] -> String
|
printImportSpecs :: [HS.ImportSpec] -> String
|
||||||
printImportSpecs ins
|
printImportSpecs ins
|
||||||
@@ -26,7 +26,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
|
|||||||
in " " ++ printSpec x ++ "\n" ++ go xs
|
in " " ++ printSpec x ++ "\n" ++ go xs
|
||||||
where
|
where
|
||||||
go [] = ""
|
go [] = ""
|
||||||
go [x'] = " , " ++ printSpec x'
|
go [x'] = " , " ++ printSpec x' ++ "\n"
|
||||||
go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs'
|
go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs'
|
||||||
printSpec :: HS.ImportSpec -> String
|
printSpec :: HS.ImportSpec -> String
|
||||||
printSpec = HS.prettyPrint
|
printSpec = HS.prettyPrint
|
||||||
|
|||||||
41
hsfm.cabal
41
hsfm.cabal
@@ -27,6 +27,7 @@ library
|
|||||||
HSFM.FileSystem.Errors
|
HSFM.FileSystem.Errors
|
||||||
HSFM.FileSystem.FileOperations
|
HSFM.FileSystem.FileOperations
|
||||||
HSFM.FileSystem.FileType
|
HSFM.FileSystem.FileType
|
||||||
|
HSFM.FileSystem.UtilTypes
|
||||||
HSFM.Utils.IO
|
HSFM.Utils.IO
|
||||||
HSFM.Utils.MyPrelude
|
HSFM.Utils.MyPrelude
|
||||||
|
|
||||||
@@ -36,7 +37,7 @@ library
|
|||||||
containers,
|
containers,
|
||||||
data-default,
|
data-default,
|
||||||
filepath >= 1.3.0.0,
|
filepath >= 1.3.0.0,
|
||||||
hinotify,
|
hinotify-bytestring,
|
||||||
hpath,
|
hpath,
|
||||||
mtl >= 2.2,
|
mtl >= 2.2,
|
||||||
old-locale >= 1,
|
old-locale >= 1,
|
||||||
@@ -66,6 +67,7 @@ executable hsfm-gtk
|
|||||||
other-modules:
|
other-modules:
|
||||||
HSFM.GUI.Glib.GlibString
|
HSFM.GUI.Glib.GlibString
|
||||||
HSFM.GUI.Gtk.Callbacks
|
HSFM.GUI.Gtk.Callbacks
|
||||||
|
HSFM.GUI.Gtk.Callbacks.Utils
|
||||||
HSFM.GUI.Gtk.Data
|
HSFM.GUI.Gtk.Data
|
||||||
HSFM.GUI.Gtk.Dialogs
|
HSFM.GUI.Gtk.Dialogs
|
||||||
HSFM.GUI.Gtk.Errors
|
HSFM.GUI.Gtk.Errors
|
||||||
@@ -84,7 +86,7 @@ executable hsfm-gtk
|
|||||||
filepath >= 1.3.0.0,
|
filepath >= 1.3.0.0,
|
||||||
glib >= 0.13,
|
glib >= 0.13,
|
||||||
gtk3 >= 0.14.1,
|
gtk3 >= 0.14.1,
|
||||||
hinotify,
|
hinotify-bytestring,
|
||||||
hpath,
|
hpath,
|
||||||
hsfm,
|
hsfm,
|
||||||
mtl >= 2.2,
|
mtl >= 2.2,
|
||||||
@@ -111,3 +113,38 @@ executable hsfm-gtk
|
|||||||
-threaded
|
-threaded
|
||||||
-Wall
|
-Wall
|
||||||
"-with-rtsopts=-N"
|
"-with-rtsopts=-N"
|
||||||
|
|
||||||
|
|
||||||
|
Test-Suite spec
|
||||||
|
Type: exitcode-stdio-1.0
|
||||||
|
Default-Language: Haskell2010
|
||||||
|
Hs-Source-Dirs: test
|
||||||
|
Main-Is: Main.hs
|
||||||
|
other-modules:
|
||||||
|
Spec
|
||||||
|
FileSystem.FileOperations.CopyDirRecursiveSpec
|
||||||
|
FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec
|
||||||
|
FileSystem.FileOperations.CopyFileSpec
|
||||||
|
FileSystem.FileOperations.CopyFileOverwriteSpec
|
||||||
|
FileSystem.FileOperations.CreateDirSpec
|
||||||
|
FileSystem.FileOperations.CreateRegularFileSpec
|
||||||
|
FileSystem.FileOperations.DeleteDirRecursiveSpec
|
||||||
|
FileSystem.FileOperations.DeleteDirSpec
|
||||||
|
FileSystem.FileOperations.DeleteFileSpec
|
||||||
|
FileSystem.FileOperations.GetDirsFilesSpec
|
||||||
|
FileSystem.FileOperations.GetFileTypeSpec
|
||||||
|
FileSystem.FileOperations.MoveFileSpec
|
||||||
|
FileSystem.FileOperations.MoveFileOverwriteSpec
|
||||||
|
FileSystem.FileOperations.RecreateSymlinkSpec
|
||||||
|
FileSystem.FileOperations.RenameFileSpec
|
||||||
|
Utils
|
||||||
|
GHC-Options: -Wall
|
||||||
|
Build-Depends: base
|
||||||
|
, HUnit
|
||||||
|
, bytestring
|
||||||
|
, hpath
|
||||||
|
, hsfm
|
||||||
|
, hspec >= 1.3
|
||||||
|
, process
|
||||||
|
, unix
|
||||||
|
, utf8-string
|
||||||
|
|||||||
@@ -17,6 +17,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
|||||||
--}
|
--}
|
||||||
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
-- |Provides error handling.
|
-- |Provides error handling.
|
||||||
@@ -26,19 +27,27 @@ module HSFM.FileSystem.Errors where
|
|||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
(
|
(
|
||||||
when
|
forM
|
||||||
, forM
|
, when
|
||||||
)
|
)
|
||||||
import Data.ByteString
|
import Data.ByteString
|
||||||
(
|
(
|
||||||
ByteString
|
ByteString
|
||||||
)
|
)
|
||||||
|
import Data.Data
|
||||||
|
(
|
||||||
|
Data(..)
|
||||||
|
)
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
(
|
(
|
||||||
getErrno
|
getErrno
|
||||||
, Errno
|
, Errno
|
||||||
)
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType
|
||||||
|
)
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
import HPath
|
import HPath
|
||||||
(
|
(
|
||||||
@@ -49,10 +58,15 @@ import HSFM.Utils.IO
|
|||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
(
|
(
|
||||||
catchIOError
|
catchIOError
|
||||||
|
, ioeGetErrorType
|
||||||
)
|
)
|
||||||
|
|
||||||
import qualified System.Posix.Directory.ByteString as PFD
|
import qualified System.Posix.Directory.ByteString as PFD
|
||||||
import System.Posix.FilePath
|
import System.Posix.Files.ByteString
|
||||||
|
(
|
||||||
|
fileAccess
|
||||||
|
, getFileStatus
|
||||||
|
)
|
||||||
import qualified System.Posix.Files.ByteString as PF
|
import qualified System.Posix.Files.ByteString as PF
|
||||||
|
|
||||||
|
|
||||||
@@ -72,7 +86,7 @@ data FmIOException = FileDoesNotExist ByteString
|
|||||||
| Can'tOpenDirectory ByteString
|
| Can'tOpenDirectory ByteString
|
||||||
| CopyFailed String
|
| CopyFailed String
|
||||||
| MoveFailed String
|
| MoveFailed String
|
||||||
deriving (Typeable)
|
deriving (Typeable, Eq, Data)
|
||||||
|
|
||||||
|
|
||||||
instance Show FmIOException where
|
instance Show FmIOException where
|
||||||
@@ -106,6 +120,26 @@ instance Exception FmIOException
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
isDestinationInSource :: FmIOException -> Bool
|
||||||
|
isDestinationInSource (DestinationInSource _ _) = True
|
||||||
|
isDestinationInSource _ = False
|
||||||
|
|
||||||
|
|
||||||
|
isSameFile :: FmIOException -> Bool
|
||||||
|
isSameFile (SameFile _ _) = True
|
||||||
|
isSameFile _ = False
|
||||||
|
|
||||||
|
|
||||||
|
isFileDoesExist :: FmIOException -> Bool
|
||||||
|
isFileDoesExist (FileDoesExist _) = True
|
||||||
|
isFileDoesExist _ = False
|
||||||
|
|
||||||
|
|
||||||
|
isDirDoesExist :: FmIOException -> Bool
|
||||||
|
isDirDoesExist (DirDoesExist _) = True
|
||||||
|
isDirDoesExist _ = False
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
----------------------------
|
----------------------------
|
||||||
--[ Path based functions ]--
|
--[ Path based functions ]--
|
||||||
@@ -126,28 +160,38 @@ throwDirDoesExist fp =
|
|||||||
|
|
||||||
throwFileDoesNotExist :: Path Abs -> IO ()
|
throwFileDoesNotExist :: Path Abs -> IO ()
|
||||||
throwFileDoesNotExist fp =
|
throwFileDoesNotExist fp =
|
||||||
whenM (doesFileExist fp) (throw . FileDoesExist
|
unlessM (doesFileExist fp) (throw . FileDoesNotExist
|
||||||
. P.fromAbs $ fp)
|
. P.fromAbs $ fp)
|
||||||
|
|
||||||
|
|
||||||
throwDirDoesNotExist :: Path Abs -> IO ()
|
throwDirDoesNotExist :: Path Abs -> IO ()
|
||||||
throwDirDoesNotExist fp =
|
throwDirDoesNotExist fp =
|
||||||
whenM (doesDirectoryExist fp) (throw . DirDoesExist
|
unlessM (doesDirectoryExist fp) (throw . DirDoesNotExist
|
||||||
. P.fromAbs $ fp)
|
. P.fromAbs $ fp)
|
||||||
|
|
||||||
|
|
||||||
throwSameFile :: Path Abs -- ^ will be canonicalized
|
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
|
||||||
-> Path Abs -- ^ will be canonicalized
|
throwSameFile :: Path Abs
|
||||||
|
-> Path Abs
|
||||||
-> IO ()
|
-> IO ()
|
||||||
throwSameFile fp1 fp2 = do
|
throwSameFile fp1 fp2 =
|
||||||
fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
|
whenM (sameFile fp1 fp2)
|
||||||
-- TODO: clean this up... if canonicalizing fp2 fails we try to
|
(throw $ SameFile (P.fromAbs fp1) (P.fromAbs fp2))
|
||||||
-- canonicalize `dirname fp2`
|
|
||||||
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
|
|
||||||
(\_ -> fmap P.fromAbs
|
-- |Check if the files are the same by examining device and file id.
|
||||||
$ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
|
-- This follows symbolic links.
|
||||||
<$> (P.canonicalizePath $ P.dirname fp2))
|
sameFile :: Path Abs -> Path Abs -> IO Bool
|
||||||
when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
|
sameFile fp1 fp2 =
|
||||||
|
P.withAbsPath fp1 $ \fp1' -> P.withAbsPath fp2 $ \fp2' ->
|
||||||
|
handleIOError (\_ -> return False) $ do
|
||||||
|
fs1 <- getFileStatus fp1'
|
||||||
|
fs2 <- getFileStatus fp2'
|
||||||
|
|
||||||
|
if ((PF.deviceID fs1, PF.fileID fs1) ==
|
||||||
|
(PF.deviceID fs2, PF.fileID fs2))
|
||||||
|
then return True
|
||||||
|
else return False
|
||||||
|
|
||||||
|
|
||||||
-- |Checks whether the destination directory is contained
|
-- |Checks whether the destination directory is contained
|
||||||
@@ -159,41 +203,45 @@ throwDestinationInSource :: Path Abs -- ^ source dir
|
|||||||
-- must exist
|
-- must exist
|
||||||
-> IO ()
|
-> IO ()
|
||||||
throwDestinationInSource source dest = do
|
throwDestinationInSource source dest = do
|
||||||
source' <- P.canonicalizePath source
|
|
||||||
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
|
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
|
||||||
<$> (P.canonicalizePath $ P.dirname dest)
|
<$> (P.canonicalizePath $ P.dirname dest)
|
||||||
dids <- forM (P.getAllParents dest') $ \p -> do
|
dids <- forM (P.getAllParents dest') $ \p -> do
|
||||||
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
|
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
|
||||||
return (PF.deviceID fs, PF.fileID fs)
|
return (PF.deviceID fs, PF.fileID fs)
|
||||||
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
|
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
|
||||||
$ PF.getSymbolicLinkStatus (P.fromAbs source')
|
$ PF.getFileStatus (P.fromAbs source)
|
||||||
when (elem sid dids)
|
when (elem sid dids)
|
||||||
(throw $ DestinationInSource (P.fromAbs dest)
|
(throw $ DestinationInSource (P.fromAbs dest)
|
||||||
(P.fromAbs source))
|
(P.fromAbs source))
|
||||||
|
|
||||||
|
|
||||||
-- |Checks if the given file exists and is not a directory. This follows
|
-- |Checks if the given file exists and is not a directory.
|
||||||
-- symlinks, but will return True if the symlink is broken.
|
-- Does not follow symlinks.
|
||||||
doesFileExist :: Path Abs -> IO Bool
|
doesFileExist :: Path Abs -> IO Bool
|
||||||
doesFileExist fp =
|
doesFileExist fp =
|
||||||
handleIOError (\_ -> return False) $ do
|
handleIOError (\_ -> return False) $ do
|
||||||
fp' <- fmap P.fromAbs $ P.canonicalizePath fp
|
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
|
||||||
fs <- PF.getFileStatus fp'
|
|
||||||
return $ not . PF.isDirectory $ fs
|
return $ not . PF.isDirectory $ fs
|
||||||
|
|
||||||
|
|
||||||
-- |Checks if the given file exists and is a directory. This follows
|
-- |Checks if the given file exists and is a directory.
|
||||||
-- symlinks, but will return False if the symlink is broken.
|
-- Does not follow symlinks.
|
||||||
doesDirectoryExist :: Path Abs -> IO Bool
|
doesDirectoryExist :: Path Abs -> IO Bool
|
||||||
doesDirectoryExist fp =
|
doesDirectoryExist fp =
|
||||||
handleIOError (\_ -> return False) $ do
|
handleIOError (\_ -> return False) $ do
|
||||||
fp' <- fmap P.fromAbs $ P.canonicalizePath fp
|
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
|
||||||
fs <- PF.getFileStatus fp'
|
|
||||||
return $ PF.isDirectory fs
|
return $ PF.isDirectory fs
|
||||||
|
|
||||||
|
|
||||||
|
-- |Checks whether a file or folder is writable.
|
||||||
|
isWritable :: Path Abs -> IO Bool
|
||||||
|
isWritable fp =
|
||||||
|
handleIOError (\_ -> return False) $
|
||||||
|
fileAccess (P.fromAbs fp) False True False
|
||||||
|
|
||||||
|
|
||||||
-- |Checks whether the directory at the given path exists and can be
|
-- |Checks whether the directory at the given path exists and can be
|
||||||
-- opened. This invokes `openDirStream`.
|
-- opened. This invokes `openDirStream` which follows symlinks.
|
||||||
canOpenDirectory :: Path Abs -> IO Bool
|
canOpenDirectory :: Path Abs -> IO Bool
|
||||||
canOpenDirectory fp =
|
canOpenDirectory fp =
|
||||||
handleIOError (\_ -> return False) $ do
|
handleIOError (\_ -> return False) $ do
|
||||||
@@ -249,3 +297,43 @@ rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
|
|||||||
handleIOError :: (IOError -> IO a) -> IO a -> IO a
|
handleIOError :: (IOError -> IO a) -> IO a -> IO a
|
||||||
handleIOError = flip catchIOError
|
handleIOError = flip catchIOError
|
||||||
|
|
||||||
|
|
||||||
|
-- |Like `bracket`, but allows to have different clean-up
|
||||||
|
-- actions depending on whether the in-between computation
|
||||||
|
-- has raised an exception or not.
|
||||||
|
bracketeer :: IO a -- ^ computation to run first
|
||||||
|
-> (a -> IO b) -- ^ computation to run last, when
|
||||||
|
-- no exception was raised
|
||||||
|
-> (a -> IO b) -- ^ computation to run last,
|
||||||
|
-- when an exception was raised
|
||||||
|
-> (a -> IO c) -- ^ computation to run in-between
|
||||||
|
-> IO c
|
||||||
|
bracketeer before after afterEx thing =
|
||||||
|
mask $ \restore -> do
|
||||||
|
a <- before
|
||||||
|
r <- restore (thing a) `onException` afterEx a
|
||||||
|
_ <- after a
|
||||||
|
return r
|
||||||
|
|
||||||
|
|
||||||
|
reactOnError :: IO a
|
||||||
|
-> [(IOErrorType, IO a)] -- ^ reaction on IO errors
|
||||||
|
-> [(FmIOException, IO a)] -- ^ reaction on FmIOException
|
||||||
|
-> IO a
|
||||||
|
reactOnError a ios fmios =
|
||||||
|
a `catches` [iohandler, fmiohandler]
|
||||||
|
where
|
||||||
|
iohandler = Handler $
|
||||||
|
\(ex :: IOException) ->
|
||||||
|
foldr (\(t, a') y -> if ioeGetErrorType ex == t
|
||||||
|
then a'
|
||||||
|
else y)
|
||||||
|
(throwIO ex)
|
||||||
|
ios
|
||||||
|
fmiohandler = Handler $
|
||||||
|
\(ex :: FmIOException) ->
|
||||||
|
foldr (\(t, a') y -> if toConstr ex == toConstr t
|
||||||
|
then a'
|
||||||
|
else y)
|
||||||
|
(throwIO ex)
|
||||||
|
fmios
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@@ -18,39 +18,44 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
|||||||
|
|
||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
-- |This module provides data types for representing directories/files
|
|
||||||
-- and related operations on it, mostly internal stuff.
|
-- |This module provides a data type for representing directories/files
|
||||||
|
-- in a well-typed and convenient way. This is useful to gather and
|
||||||
|
-- save information about a file, so the information can be easily
|
||||||
|
-- processed in e.g. a GUI.
|
||||||
--
|
--
|
||||||
-- It doesn't allow to represent the whole filesystem, since that's only
|
-- However, it's not meant to be used to interact with low-level
|
||||||
-- possible through IO laziness, which introduces too much internal state.
|
-- functions that copy files etc, since there's no guarantee that
|
||||||
|
-- the in-memory representation of the type still matches what is
|
||||||
|
-- happening on filesystem level.
|
||||||
|
--
|
||||||
|
-- If you interact with low-level libraries, you must not pattern
|
||||||
|
-- match on the `File a` type. Instead, you should only use the saved
|
||||||
|
-- `path` and make no assumptions about the file the path might or
|
||||||
|
-- might not point to.
|
||||||
module HSFM.FileSystem.FileType where
|
module HSFM.FileSystem.FileType where
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
import Data.ByteString(ByteString)
|
import Data.ByteString(ByteString)
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Maybe
|
|
||||||
(
|
|
||||||
catMaybes
|
|
||||||
)
|
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
(
|
(
|
||||||
POSIXTime
|
POSIXTime
|
||||||
, posixSecondsToUTCTime
|
, posixSecondsToUTCTime
|
||||||
)
|
)
|
||||||
import Data.Time()
|
import Data.Time()
|
||||||
import Foreign.C.Error
|
|
||||||
(
|
|
||||||
eACCES
|
|
||||||
)
|
|
||||||
import HPath
|
import HPath
|
||||||
(
|
(
|
||||||
Abs
|
Abs
|
||||||
, Path
|
, Path
|
||||||
, Fn
|
|
||||||
)
|
)
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
import HSFM.FileSystem.Errors
|
import HSFM.FileSystem.Errors
|
||||||
|
import HSFM.FileSystem.FileOperations
|
||||||
|
(
|
||||||
|
getDirsFiles
|
||||||
|
)
|
||||||
import HSFM.Utils.MyPrelude
|
import HSFM.Utils.MyPrelude
|
||||||
import Prelude hiding(readFile)
|
import Prelude hiding(readFile)
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
@@ -64,8 +69,7 @@ import System.Posix.FilePath
|
|||||||
)
|
)
|
||||||
import System.Posix.Directory.Traversals
|
import System.Posix.Directory.Traversals
|
||||||
(
|
(
|
||||||
getDirectoryContents
|
realpath
|
||||||
, realpath
|
|
||||||
)
|
)
|
||||||
import qualified System.Posix.Files.ByteString as PF
|
import qualified System.Posix.Files.ByteString as PF
|
||||||
import System.Posix.Types
|
import System.Posix.Types
|
||||||
@@ -93,62 +97,61 @@ import System.Posix.Types
|
|||||||
-- |The String in the path field is always a full path.
|
-- |The String in the path field is always a full path.
|
||||||
-- The free type variable is used in the File/Dir constructor and can hold
|
-- The free type variable is used in the File/Dir constructor and can hold
|
||||||
-- Handles, Strings representing a file's contents or anything else you can
|
-- Handles, Strings representing a file's contents or anything else you can
|
||||||
-- think of. We catch any IO errors in the Failed constructor. an Exception
|
-- think of. We catch any IO errors in the Failed constructor.
|
||||||
-- can be converted to a String with 'show'.
|
|
||||||
data File a =
|
data File a =
|
||||||
Failed {
|
Failed {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, err :: IOError
|
, err :: IOError
|
||||||
}
|
}
|
||||||
| Dir {
|
| Dir {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
| RegFile {
|
| RegFile {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
| SymLink {
|
| SymLink {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
, sdest :: File a -- ^ symlink madness,
|
, sdest :: File a -- ^ symlink madness,
|
||||||
-- we need to know where it points to
|
-- we need to know where it points to
|
||||||
, rawdest :: ByteString
|
, rawdest :: !ByteString
|
||||||
}
|
}
|
||||||
| BlockDev {
|
| BlockDev {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
| CharDev {
|
| CharDev {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
| NamedPipe {
|
| NamedPipe {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
| Socket {
|
| Socket {
|
||||||
path :: Path Abs
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
} deriving (Show, Eq)
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
|
||||||
-- |Low-level file information.
|
-- |Low-level file information.
|
||||||
data FileInfo = FileInfo {
|
data FileInfo = FileInfo {
|
||||||
deviceID :: DeviceID
|
deviceID :: !DeviceID
|
||||||
, fileID :: FileID
|
, fileID :: !FileID
|
||||||
, fileMode :: FileMode
|
, fileMode :: !FileMode
|
||||||
, linkCount :: LinkCount
|
, linkCount :: !LinkCount
|
||||||
, fileOwner :: UserID
|
, fileOwner :: !UserID
|
||||||
, fileGroup :: GroupID
|
, fileGroup :: !GroupID
|
||||||
, specialDeviceID :: DeviceID
|
, specialDeviceID :: !DeviceID
|
||||||
, fileSize :: FileOffset
|
, fileSize :: !FileOffset
|
||||||
, accessTime :: EpochTime
|
, accessTime :: !EpochTime
|
||||||
, modificationTime :: EpochTime
|
, modificationTime :: !EpochTime
|
||||||
, statusChangeTime :: EpochTime
|
, statusChangeTime :: !EpochTime
|
||||||
, accessTimeHiRes :: POSIXTime
|
, accessTimeHiRes :: !POSIXTime
|
||||||
, modificationTimeHiRes :: POSIXTime
|
, modificationTimeHiRes :: !POSIXTime
|
||||||
, statusChangeTimeHiRes :: POSIXTime
|
, statusChangeTimeHiRes :: !POSIXTime
|
||||||
} deriving (Show, Eq, Ord)
|
} deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
|
||||||
@@ -461,19 +464,7 @@ isSocketC _ = False
|
|||||||
---- IO HELPERS: ----
|
---- IO HELPERS: ----
|
||||||
|
|
||||||
|
|
||||||
-- |Gets all filenames of the given directory. This excludes "." and "..".
|
|
||||||
getDirsFiles :: Path Abs -- ^ dir to read
|
|
||||||
-> IO [Path Abs]
|
|
||||||
getDirsFiles p =
|
|
||||||
P.withAbsPath p $ \fp ->
|
|
||||||
rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
|
|
||||||
$ return
|
|
||||||
. catMaybes
|
|
||||||
. fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
|
|
||||||
=<< getDirectoryContents fp
|
|
||||||
where
|
|
||||||
parseMaybe :: ByteString -> Maybe (Path Fn)
|
|
||||||
parseMaybe = P.parseFn
|
|
||||||
|
|
||||||
|
|
||||||
-- |Gets all file information.
|
-- |Gets all file information.
|
||||||
@@ -563,9 +554,17 @@ getFreeVar _ = Nothing
|
|||||||
-- |Pack the modification time into a string.
|
-- |Pack the modification time into a string.
|
||||||
packModTime :: File FileInfo
|
packModTime :: File FileInfo
|
||||||
-> String
|
-> String
|
||||||
packModTime =
|
packModTime = fromFreeVar $ epochToString . modificationTime
|
||||||
fromFreeVar
|
|
||||||
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
|
|
||||||
|
-- |Pack the modification time into a string.
|
||||||
|
packAccessTime :: File FileInfo
|
||||||
|
-> String
|
||||||
|
packAccessTime = fromFreeVar $ epochToString . accessTime
|
||||||
|
|
||||||
|
|
||||||
|
epochToString :: EpochTime -> String
|
||||||
|
epochToString = show . posixSecondsToUTCTime . realToFrac
|
||||||
|
|
||||||
|
|
||||||
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
||||||
@@ -599,3 +598,21 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
|||||||
| otherwise = "-"
|
| otherwise = "-"
|
||||||
hasFM fm = ffm `PF.intersectFileModes` fm == fm
|
hasFM fm = ffm `PF.intersectFileModes` fm == fm
|
||||||
|
|
||||||
|
|
||||||
|
packFileType :: File a -> String
|
||||||
|
packFileType file = case file of
|
||||||
|
Dir {} -> "Directory"
|
||||||
|
RegFile {} -> "Regular File"
|
||||||
|
SymLink {} -> "Symbolic Link"
|
||||||
|
BlockDev {} -> "Block Device"
|
||||||
|
CharDev {} -> "Char Device"
|
||||||
|
NamedPipe {} -> "Named Pipe"
|
||||||
|
Socket {} -> "Socket"
|
||||||
|
_ -> "Unknown"
|
||||||
|
|
||||||
|
|
||||||
|
packLinkDestination :: File a -> Maybe ByteString
|
||||||
|
packLinkDestination file = case file of
|
||||||
|
SymLink { rawdest = dest } -> Just dest
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|||||||
84
src/HSFM/FileSystem/UtilTypes.hs
Normal file
84
src/HSFM/FileSystem/UtilTypes.hs
Normal file
@@ -0,0 +1,84 @@
|
|||||||
|
{--
|
||||||
|
HSFM, a filemanager written in Haskell.
|
||||||
|
Copyright (C) 2016 Julian Ospald
|
||||||
|
|
||||||
|
This program is free software; you can redistribute it and/or
|
||||||
|
modify it under the terms of the GNU General Public License
|
||||||
|
version 2 as published by the Free Software Foundation.
|
||||||
|
|
||||||
|
This program is distributed in the hope that it will be useful,
|
||||||
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
GNU General Public License for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU General Public License
|
||||||
|
along with this program; if not, write to the Free Software
|
||||||
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||||
|
--}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
|
|
||||||
|
-- |This module provides high-level IO related file operations like
|
||||||
|
-- copy, delete, move and so on. It only operates on `Path Abs` which
|
||||||
|
-- guarantees us well-typed paths which are absolute.
|
||||||
|
--
|
||||||
|
-- Some functions are just path-safe wrappers around
|
||||||
|
-- unix functions, others have stricter exception handling
|
||||||
|
-- and some implement functionality that doesn't have a unix
|
||||||
|
-- counterpart (like `copyDirRecursive`).
|
||||||
|
--
|
||||||
|
-- Some of these operations are due to their nature not _atomic_, which
|
||||||
|
-- means they may do multiple syscalls which form one context. Some
|
||||||
|
-- of them also have to examine the filetypes explicitly before the
|
||||||
|
-- syscalls, so a reasonable decision can be made. That means
|
||||||
|
-- the result is undefined if another process changes that context
|
||||||
|
-- while the non-atomic operation is still happening. However, where
|
||||||
|
-- possible, as few syscalls as possible are used and the underlying
|
||||||
|
-- exception handling is kept.
|
||||||
|
module HSFM.FileSystem.UtilTypes where
|
||||||
|
|
||||||
|
|
||||||
|
import Data.ByteString
|
||||||
|
(
|
||||||
|
ByteString
|
||||||
|
)
|
||||||
|
import HPath
|
||||||
|
(
|
||||||
|
Path
|
||||||
|
, Abs
|
||||||
|
, Fn
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
-- |Data type describing file operations.
|
||||||
|
-- Useful to build up a list of operations or delay operations.
|
||||||
|
data FileOperation = FCopy Copy
|
||||||
|
| FMove Move
|
||||||
|
| FDelete [Path Abs]
|
||||||
|
| FOpen (Path Abs)
|
||||||
|
| FExecute (Path Abs) [ByteString]
|
||||||
|
| None
|
||||||
|
|
||||||
|
|
||||||
|
-- |Data type describing partial or complete file copy operation.
|
||||||
|
data Copy = PartialCopy [Path Abs] -- source files
|
||||||
|
| Copy [Path Abs] -- source files
|
||||||
|
(Path Abs) -- base destination directory
|
||||||
|
|
||||||
|
|
||||||
|
-- |Data type describing partial or complete file move operation.
|
||||||
|
data Move = PartialMove [Path Abs] -- source files
|
||||||
|
| Move [Path Abs] -- source files
|
||||||
|
(Path Abs) -- base destination directory
|
||||||
|
|
||||||
|
|
||||||
|
-- |Collision modes that describe the behavior in case a file collision
|
||||||
|
-- happens.
|
||||||
|
data FCollisonMode = Strict -- ^ fail if the target already exists
|
||||||
|
| Overwrite
|
||||||
|
| OverwriteAll
|
||||||
|
| Skip
|
||||||
|
| Rename (Path Fn)
|
||||||
|
|
||||||
@@ -29,6 +29,7 @@ import Data.Maybe
|
|||||||
)
|
)
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
|
import HSFM.GUI.Gtk.Callbacks
|
||||||
import HSFM.GUI.Gtk.Data
|
import HSFM.GUI.Gtk.Data
|
||||||
import HSFM.GUI.Gtk.MyGUI
|
import HSFM.GUI.Gtk.MyGUI
|
||||||
import HSFM.GUI.Gtk.MyView
|
import HSFM.GUI.Gtk.MyView
|
||||||
@@ -44,14 +45,13 @@ main = do
|
|||||||
_ <- initGUI
|
_ <- initGUI
|
||||||
|
|
||||||
args <- SPE.getArgs
|
args <- SPE.getArgs
|
||||||
|
|
||||||
mygui <- createMyGUI
|
|
||||||
|
|
||||||
myview <- createMyView mygui createTreeView
|
|
||||||
|
|
||||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
||||||
(P.parseAbs . headDef "/" $ args)
|
(P.parseAbs . headDef "/" $ args)
|
||||||
refreshView mygui myview (Just $ mdir)
|
|
||||||
|
mygui <- createMyGUI
|
||||||
|
_ <- newTab mygui createTreeView mdir
|
||||||
|
|
||||||
|
setGUICallbacks mygui
|
||||||
|
|
||||||
widgetShowAll (rootWin mygui)
|
widgetShowAll (rootWin mygui)
|
||||||
|
|
||||||
|
|||||||
@@ -32,13 +32,18 @@ import Control.Exception
|
|||||||
)
|
)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
(
|
(
|
||||||
void
|
forM_
|
||||||
, forM_
|
, void
|
||||||
|
, when
|
||||||
)
|
)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
(
|
(
|
||||||
liftIO
|
liftIO
|
||||||
)
|
)
|
||||||
|
import Data.ByteString
|
||||||
|
(
|
||||||
|
ByteString
|
||||||
|
)
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
(
|
(
|
||||||
for_
|
for_
|
||||||
@@ -53,6 +58,8 @@ import HPath
|
|||||||
import HSFM.FileSystem.Errors
|
import HSFM.FileSystem.Errors
|
||||||
import HSFM.FileSystem.FileOperations
|
import HSFM.FileSystem.FileOperations
|
||||||
import HSFM.FileSystem.FileType
|
import HSFM.FileSystem.FileType
|
||||||
|
import HSFM.FileSystem.UtilTypes
|
||||||
|
import HSFM.GUI.Gtk.Callbacks.Utils
|
||||||
import HSFM.GUI.Gtk.Data
|
import HSFM.GUI.Gtk.Data
|
||||||
import HSFM.GUI.Gtk.Dialogs
|
import HSFM.GUI.Gtk.Dialogs
|
||||||
import HSFM.GUI.Gtk.MyView
|
import HSFM.GUI.Gtk.MyView
|
||||||
@@ -67,6 +74,12 @@ import System.Posix.Env.ByteString
|
|||||||
(
|
(
|
||||||
getEnv
|
getEnv
|
||||||
)
|
)
|
||||||
|
import qualified System.Posix.Process.ByteString as SPP
|
||||||
|
import System.Posix.Types
|
||||||
|
(
|
||||||
|
ProcessID
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -76,14 +89,75 @@ import System.Posix.Env.ByteString
|
|||||||
-----------------
|
-----------------
|
||||||
|
|
||||||
|
|
||||||
-- |Set callbacks, on hotkeys, events and stuff.
|
|
||||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
|
||||||
setCallbacks mygui myview = do
|
---- MAIN CALLBACK ENTRYPOINT ----
|
||||||
|
|
||||||
|
|
||||||
|
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
|
||||||
|
setGUICallbacks :: MyGUI -> IO ()
|
||||||
|
setGUICallbacks mygui = do
|
||||||
|
|
||||||
|
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
||||||
|
popStatusbar mygui
|
||||||
|
writeTVarIO (operationBuffer mygui) None
|
||||||
|
|
||||||
|
-- menubar-file
|
||||||
|
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
|
||||||
|
mainQuit
|
||||||
|
|
||||||
|
-- menubar-help
|
||||||
|
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
|
||||||
|
liftIO showAboutDialog
|
||||||
|
return ()
|
||||||
|
|
||||||
|
-- key events
|
||||||
|
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||||
|
[Control] <- eventModifier
|
||||||
|
"q" <- fmap glibToString eventKeyName
|
||||||
|
liftIO mainQuit
|
||||||
|
|
||||||
|
return ()
|
||||||
|
|
||||||
|
|
||||||
|
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
|
||||||
|
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||||
|
setViewCallbacks mygui myview = do
|
||||||
view' <- readTVarIO $ view myview
|
view' <- readTVarIO $ view myview
|
||||||
case view' of
|
case view' of
|
||||||
fmv@(FMTreeView treeView) -> do
|
fmv@(FMTreeView treeView) -> do
|
||||||
_ <- treeView `on` rowActivated
|
_ <- treeView `on` rowActivated
|
||||||
$ (\_ _ -> withItems mygui myview open)
|
$ (\_ _ -> withItems mygui myview open)
|
||||||
|
|
||||||
|
-- drag events
|
||||||
|
_ <- treeView `on` dragBegin $
|
||||||
|
\_ -> withItems mygui myview moveInit
|
||||||
|
_ <- treeView `on` dragDrop $
|
||||||
|
\dc p ts -> do
|
||||||
|
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
||||||
|
mpath <- treeViewGetPathAtPos treeView p'
|
||||||
|
case mpath of
|
||||||
|
Nothing -> do
|
||||||
|
dragFinish dc False False ts
|
||||||
|
return False
|
||||||
|
Just _ -> do
|
||||||
|
atom <- atomNew ("HSFM" :: String)
|
||||||
|
dragGetData treeView dc atom ts
|
||||||
|
return True
|
||||||
|
_ <- treeView `on` dragDataReceived $
|
||||||
|
\dc p _ ts ->
|
||||||
|
liftIO $ do
|
||||||
|
signalStopEmission treeView "drag_data_received"
|
||||||
|
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
||||||
|
mpath <- treeViewGetPathAtPos treeView p'
|
||||||
|
case mpath of
|
||||||
|
Nothing -> dragFinish dc False False ts
|
||||||
|
Just (tp, _, _) -> do
|
||||||
|
mitem <- rawPathToItem myview tp
|
||||||
|
forM_ mitem $ \item ->
|
||||||
|
operationFinal mygui myview (Just item)
|
||||||
|
dragFinish dc True False ts
|
||||||
|
|
||||||
commonGuiEvents fmv
|
commonGuiEvents fmv
|
||||||
return ()
|
return ()
|
||||||
fmv@(FMIconView iconView) -> do
|
fmv@(FMIconView iconView) -> do
|
||||||
@@ -91,73 +165,40 @@ setCallbacks mygui myview = do
|
|||||||
$ (\_ -> withItems mygui myview open)
|
$ (\_ -> withItems mygui myview open)
|
||||||
commonGuiEvents fmv
|
commonGuiEvents fmv
|
||||||
return ()
|
return ()
|
||||||
menubarCallbacks
|
|
||||||
where
|
where
|
||||||
menubarCallbacks = do
|
|
||||||
-- menubar-file
|
|
||||||
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
|
|
||||||
_ <- menubarFileOpen mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview open
|
|
||||||
_ <- menubarFileExecute mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview execute
|
|
||||||
_ <- menubarFileNew mygui `on` menuItemActivated $
|
|
||||||
liftIO $ newFile mygui myview
|
|
||||||
|
|
||||||
-- menubar-edit
|
|
||||||
_ <- menubarEditCut mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview moveInit
|
|
||||||
_ <- menubarEditCopy mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview copyInit
|
|
||||||
_ <- menubarEditRename mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview renameF
|
|
||||||
_ <- menubarEditPaste mygui `on` menuItemActivated $
|
|
||||||
liftIO $ operationFinal mygui myview
|
|
||||||
_ <- menubarEditDelete mygui `on` menuItemActivated $
|
|
||||||
liftIO $ withItems mygui myview del
|
|
||||||
|
|
||||||
-- mewnubar-view
|
|
||||||
_ <- menubarViewIcon mygui `on` menuItemActivated $
|
|
||||||
liftIO $ switchView mygui myview createIconView
|
|
||||||
_ <- menubarViewTree mygui `on` menuItemActivated $
|
|
||||||
liftIO $ switchView mygui myview createTreeView
|
|
||||||
|
|
||||||
-- menubar-help
|
|
||||||
_ <- menubarHelpAbout mygui `on` menuItemActivated $
|
|
||||||
liftIO showAboutDialog
|
|
||||||
return ()
|
|
||||||
commonGuiEvents fmv = do
|
commonGuiEvents fmv = do
|
||||||
let view = fmViewToContainer fmv
|
let view = fmViewToContainer fmv
|
||||||
|
|
||||||
-- GUI events
|
-- GUI events
|
||||||
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
|
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
|
||||||
|
_ <- upViewB myview `on` buttonActivated $
|
||||||
_ <- upViewB mygui `on` buttonActivated $
|
|
||||||
upDir mygui myview
|
upDir mygui myview
|
||||||
_ <- homeViewB mygui `on` buttonActivated $
|
_ <- homeViewB myview `on` buttonActivated $
|
||||||
goHome mygui myview
|
goHome mygui myview
|
||||||
_ <- refreshViewB mygui `on` buttonActivated $ do
|
_ <- refreshViewB myview `on` buttonActivated $ do
|
||||||
cdir <- liftIO $ getCurrentDir myview
|
cdir <- liftIO $ getCurrentDir myview
|
||||||
refreshView' mygui myview cdir
|
refreshView' mygui myview cdir
|
||||||
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
|
||||||
popStatusbar mygui
|
|
||||||
writeTVarIO (operationBuffer myview) None
|
|
||||||
|
|
||||||
-- key events
|
-- key events
|
||||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
[Control] <- eventModifier
|
|
||||||
"q" <- fmap glibToString eventKeyName
|
|
||||||
liftIO mainQuit
|
|
||||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
|
||||||
[Control] <- eventModifier
|
[Control] <- eventModifier
|
||||||
"h" <- fmap glibToString eventKeyName
|
"h" <- fmap glibToString eventKeyName
|
||||||
cdir <- liftIO $ getCurrentDir myview
|
cdir <- liftIO $ getCurrentDir myview
|
||||||
liftIO $ modifyTVarIO (settings mygui)
|
liftIO $ modifyTVarIO (settings mygui)
|
||||||
(\x -> x { showHidden = not . showHidden $ x})
|
(\x -> x { showHidden = not . showHidden $ x})
|
||||||
>> refreshView' mygui myview cdir
|
>> refreshView' mygui myview cdir
|
||||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
[Alt] <- eventModifier
|
[Alt] <- eventModifier
|
||||||
"Up" <- fmap glibToString eventKeyName
|
"Up" <- fmap glibToString eventKeyName
|
||||||
liftIO $ upDir mygui myview
|
liftIO $ upDir mygui myview
|
||||||
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
|
[Alt] <- eventModifier
|
||||||
|
"Left" <- fmap glibToString eventKeyName
|
||||||
|
liftIO $ goHistoryPrev mygui myview
|
||||||
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
|
[Alt] <- eventModifier
|
||||||
|
"Right" <- fmap glibToString eventKeyName
|
||||||
|
liftIO $ goHistoryNext mygui myview
|
||||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||||
"Delete" <- fmap glibToString eventKeyName
|
"Delete" <- fmap glibToString eventKeyName
|
||||||
liftIO $ withItems mygui myview del
|
liftIO $ withItems mygui myview del
|
||||||
@@ -173,10 +214,23 @@ setCallbacks mygui myview = do
|
|||||||
[Control] <- eventModifier
|
[Control] <- eventModifier
|
||||||
"x" <- fmap glibToString eventKeyName
|
"x" <- fmap glibToString eventKeyName
|
||||||
liftIO $ withItems mygui myview moveInit
|
liftIO $ withItems mygui myview moveInit
|
||||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
[Control] <- eventModifier
|
[Control] <- eventModifier
|
||||||
"v" <- fmap glibToString eventKeyName
|
"v" <- fmap glibToString eventKeyName
|
||||||
liftIO $ operationFinal mygui myview
|
liftIO $ operationFinal mygui myview Nothing
|
||||||
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
|
[Control] <- eventModifier
|
||||||
|
"t" <- fmap glibToString eventKeyName
|
||||||
|
liftIO $ void $ do
|
||||||
|
cwd <- getCurrentDir myview
|
||||||
|
newTab mygui createTreeView (path cwd)
|
||||||
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
|
[Control] <- eventModifier
|
||||||
|
"w" <- fmap glibToString eventKeyName
|
||||||
|
liftIO $ void $ closeTab mygui myview
|
||||||
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
|
"F4" <- fmap glibToString eventKeyName
|
||||||
|
liftIO $ void $ openTerminalHere myview
|
||||||
|
|
||||||
-- righ-click
|
-- righ-click
|
||||||
_ <- view `on` buttonPressEvent $ do
|
_ <- view `on` buttonPressEvent $ do
|
||||||
@@ -184,7 +238,7 @@ setCallbacks mygui myview = do
|
|||||||
t <- eventTime
|
t <- eventTime
|
||||||
case eb of
|
case eb of
|
||||||
RightButton -> do
|
RightButton -> do
|
||||||
_ <- liftIO $ menuPopup (rcMenu mygui)
|
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
|
||||||
$ Just (RightButton, t)
|
$ Just (RightButton, t)
|
||||||
-- this is just to not screw with current selection
|
-- this is just to not screw with current selection
|
||||||
-- on right-click
|
-- on right-click
|
||||||
@@ -200,25 +254,42 @@ setCallbacks mygui myview = do
|
|||||||
return $ elem tp selectedTps
|
return $ elem tp selectedTps
|
||||||
-- no item under the cursor, pass on the signal
|
-- no item under the cursor, pass on the signal
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
|
OtherButton 8 -> do
|
||||||
|
liftIO $ goHistoryPrev mygui myview
|
||||||
|
return False
|
||||||
|
OtherButton 9 -> do
|
||||||
|
liftIO $ goHistoryNext mygui myview
|
||||||
|
return False
|
||||||
-- not right-click, so pass on the signal
|
-- not right-click, so pass on the signal
|
||||||
_ -> return False
|
_ -> return False
|
||||||
_ <- rcFileOpen mygui `on` menuItemActivated $
|
|
||||||
|
-- right click menu
|
||||||
|
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview open
|
liftIO $ withItems mygui myview open
|
||||||
_ <- rcFileExecute mygui `on` menuItemActivated $
|
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview execute
|
liftIO $ withItems mygui myview execute
|
||||||
_ <- rcFileNew mygui `on` menuItemActivated $
|
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ newFile mygui myview
|
liftIO $ newFile mygui myview
|
||||||
_ <- rcFileCopy mygui `on` menuItemActivated $
|
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
|
||||||
|
liftIO $ newDir mygui myview
|
||||||
|
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview copyInit
|
liftIO $ withItems mygui myview copyInit
|
||||||
_ <- rcFileRename mygui `on` menuItemActivated $
|
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview renameF
|
liftIO $ withItems mygui myview renameF
|
||||||
_ <- rcFilePaste mygui `on` menuItemActivated $
|
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ operationFinal mygui myview
|
liftIO $ operationFinal mygui myview Nothing
|
||||||
_ <- rcFileDelete mygui `on` menuItemActivated $
|
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview del
|
liftIO $ withItems mygui myview del
|
||||||
_ <- rcFileCut mygui `on` menuItemActivated $
|
_ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
|
||||||
|
liftIO $ withItems mygui myview showFilePropertyDialog
|
||||||
|
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
|
||||||
liftIO $ withItems mygui myview moveInit
|
liftIO $ withItems mygui myview moveInit
|
||||||
|
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
|
||||||
|
liftIO $ switchView mygui myview createIconView
|
||||||
|
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
|
||||||
|
liftIO $ switchView mygui myview createTreeView
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
getPathAtPos fmv (x, y) =
|
getPathAtPos fmv (x, y) =
|
||||||
case fmv of
|
case fmv of
|
||||||
FMTreeView treeView -> do
|
FMTreeView treeView -> do
|
||||||
@@ -230,47 +301,31 @@ setCallbacks mygui myview = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
|
||||||
-- treeView.
|
---- OTHER ----
|
||||||
--
|
|
||||||
-- If the url is invalid, does nothing.
|
|
||||||
urlGoTo :: MyGUI -> MyView -> IO ()
|
|
||||||
urlGoTo mygui myview = withErrorDialog $ do
|
|
||||||
fp <- entryGetText (urlBar mygui)
|
|
||||||
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
|
||||||
refreshView mygui myview (Just fp')
|
|
||||||
|
|
||||||
|
|
||||||
goHome :: MyGUI -> MyView -> IO ()
|
openTerminalHere :: MyView -> IO ProcessID
|
||||||
goHome mygui myview = withErrorDialog $ do
|
openTerminalHere myview = do
|
||||||
mhomedir <- getEnv "HOME"
|
cwd <- (P.fromAbs . path) <$> getCurrentDir myview
|
||||||
refreshView mygui myview (P.parseAbs =<< mhomedir)
|
-- TODO: make terminal configurable
|
||||||
|
SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
|
||||||
|
|
||||||
|
|
||||||
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
|
||||||
open :: [Item] -> MyGUI -> MyView -> IO ()
|
|
||||||
open [item] mygui myview = withErrorDialog $
|
|
||||||
case item of
|
|
||||||
DirOrSym r -> do
|
|
||||||
nv <- readFile getFileInfo $ path r
|
|
||||||
refreshView' mygui myview nv
|
|
||||||
r ->
|
|
||||||
void $ openFile r
|
|
||||||
-- this throws on the first error that occurs
|
|
||||||
open (FileLikeList fs) _ _ = withErrorDialog $
|
|
||||||
forM_ fs $ \f -> void $ openFile f
|
|
||||||
open _ _ _ = withErrorDialog
|
|
||||||
. throw $ InvalidOperation
|
|
||||||
"Operation not supported on multiple files"
|
|
||||||
|
|
||||||
|
|
||||||
-- |Execute a given file.
|
---- TAB OPERATIONS ----
|
||||||
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
|
||||||
execute [item] _ _ = withErrorDialog $
|
|
||||||
void $ executeFile item []
|
-- |Closes the current tab, but only if there is more than one tab.
|
||||||
execute _ _ _ = withErrorDialog
|
closeTab :: MyGUI -> MyView -> IO ()
|
||||||
. throw $ InvalidOperation
|
closeTab mygui myview = do
|
||||||
"Operation not supported on multiple files"
|
n <- notebookGetNPages (notebook mygui)
|
||||||
|
when (n > 1) $ void $ destroyView mygui myview
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
|
||||||
|
|
||||||
|
|
||||||
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
||||||
@@ -278,12 +333,12 @@ del :: [Item] -> MyGUI -> MyView -> IO ()
|
|||||||
del [item] _ _ = withErrorDialog $ do
|
del [item] _ _ = withErrorDialog $ do
|
||||||
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
|
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
|
||||||
withConfirmationDialog cmsg
|
withConfirmationDialog cmsg
|
||||||
$ easyDelete item
|
$ easyDelete . path $ item
|
||||||
-- this throws on the first error that occurs
|
-- this throws on the first error that occurs
|
||||||
del items@(_:_) _ _ = withErrorDialog $ do
|
del items@(_:_) _ _ = withErrorDialog $ do
|
||||||
let cmsg = "Really delete " ++ show (length items) ++ " files?"
|
let cmsg = "Really delete " ++ show (length items) ++ " files?"
|
||||||
withConfirmationDialog cmsg
|
withConfirmationDialog cmsg
|
||||||
$ forM_ items $ \item -> easyDelete item
|
$ forM_ items $ \item -> easyDelete . path $ item
|
||||||
del _ _ _ = withErrorDialog
|
del _ _ _ = withErrorDialog
|
||||||
. throw $ InvalidOperation
|
. throw $ InvalidOperation
|
||||||
"Operation not supported on multiple files"
|
"Operation not supported on multiple files"
|
||||||
@@ -291,8 +346,8 @@ del _ _ _ = withErrorDialog
|
|||||||
|
|
||||||
-- |Initializes a file move operation.
|
-- |Initializes a file move operation.
|
||||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
moveInit items@(_:_) mygui myview = do
|
moveInit items@(_:_) mygui _ = do
|
||||||
writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items)
|
writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
|
||||||
let sbmsg = case items of
|
let sbmsg = case items of
|
||||||
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
||||||
_ -> "Move buffer: " ++ (show . length $ items)
|
_ -> "Move buffer: " ++ (show . length $ items)
|
||||||
@@ -305,8 +360,8 @@ moveInit _ _ _ = withErrorDialog
|
|||||||
|
|
||||||
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
||||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
copyInit items@(_:_) mygui myview = do
|
copyInit items@(_:_) mygui _ = do
|
||||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items)
|
writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
|
||||||
let sbmsg = case items of
|
let sbmsg = case items of
|
||||||
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
||||||
_ -> "Copy buffer: " ++ (show . length $ items)
|
_ -> "Copy buffer: " ++ (show . length $ items)
|
||||||
@@ -319,25 +374,25 @@ copyInit _ _ _ = withErrorDialog
|
|||||||
|
|
||||||
|
|
||||||
-- |Finalizes a file operation, such as copy or move.
|
-- |Finalizes a file operation, such as copy or move.
|
||||||
operationFinal :: MyGUI -> MyView -> IO ()
|
operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
|
||||||
operationFinal _ myview = withErrorDialog $ do
|
operationFinal mygui myview mitem = withErrorDialog $ do
|
||||||
op <- readTVarIO (operationBuffer myview)
|
op <- readTVarIO (operationBuffer mygui)
|
||||||
cdir <- path <$> getCurrentDir myview
|
cdir <- case mitem of
|
||||||
|
Nothing -> path <$> getCurrentDir myview
|
||||||
|
Just x -> return $ path x
|
||||||
case op of
|
case op of
|
||||||
FMove (MP1 s) -> do
|
FMove (PartialMove s) -> do
|
||||||
let cmsg = "Really move " ++ imsg s
|
let cmsg = "Really move " ++ imsg s
|
||||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||||
++ "\"?"
|
++ "\"?"
|
||||||
withConfirmationDialog cmsg . withCopyModeDialog
|
withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
|
||||||
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
|
popStatusbar mygui
|
||||||
return ()
|
writeTVarIO (operationBuffer mygui) None
|
||||||
FCopy (CP1 s) -> do
|
FCopy (PartialCopy s) -> do
|
||||||
let cmsg = "Really copy " ++ imsg s
|
let cmsg = "Really copy " ++ imsg s
|
||||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||||
++ "\"?"
|
++ "\"?"
|
||||||
withConfirmationDialog cmsg . withCopyModeDialog
|
withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
|
||||||
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
|
|
||||||
return ()
|
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
where
|
where
|
||||||
imsg s = case s of
|
imsg s = case s of
|
||||||
@@ -345,27 +400,30 @@ operationFinal _ myview = withErrorDialog $ do
|
|||||||
items -> (show . length $ items) ++ " items"
|
items -> (show . length $ items) ++ " items"
|
||||||
|
|
||||||
|
|
||||||
-- |Go up one directory and visualize it in the treeView.
|
-- |Create a new file.
|
||||||
upDir :: MyGUI -> MyView -> IO ()
|
|
||||||
upDir mygui myview = withErrorDialog $ do
|
|
||||||
cdir <- getCurrentDir myview
|
|
||||||
nv <- goUp cdir
|
|
||||||
refreshView' mygui myview nv
|
|
||||||
|
|
||||||
|
|
||||||
-- |Go up one directory and visualize it in the treeView.
|
|
||||||
newFile :: MyGUI -> MyView -> IO ()
|
newFile :: MyGUI -> MyView -> IO ()
|
||||||
newFile _ myview = withErrorDialog $ do
|
newFile _ myview = withErrorDialog $ do
|
||||||
mfn <- textInputDialog "Enter file name"
|
mfn <- textInputDialog "Enter file name" ("" :: String)
|
||||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||||
for_ pmfn $ \fn -> do
|
for_ pmfn $ \fn -> do
|
||||||
cdir <- getCurrentDir myview
|
cdir <- getCurrentDir myview
|
||||||
createFile cdir fn
|
createRegularFile (path cdir P.</> fn)
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a new directory.
|
||||||
|
newDir :: MyGUI -> MyView -> IO ()
|
||||||
|
newDir _ myview = withErrorDialog $ do
|
||||||
|
mfn <- textInputDialog "Enter directory name" ("" :: String)
|
||||||
|
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||||
|
for_ pmfn $ \fn -> do
|
||||||
|
cdir <- getCurrentDir myview
|
||||||
|
createDir (path cdir P.</> fn)
|
||||||
|
|
||||||
|
|
||||||
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
renameF [item] _ _ = withErrorDialog $ do
|
renameF [item] _ _ = withErrorDialog $ do
|
||||||
mfn <- textInputDialog "Enter new file name"
|
iname <- P.fromRel <$> (P.basename $ path item)
|
||||||
|
mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
|
||||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||||
for_ pmfn $ \fn -> do
|
for_ pmfn $ \fn -> do
|
||||||
let cmsg = "Really rename \"" ++ getFPasStr item
|
let cmsg = "Really rename \"" ++ getFPasStr item
|
||||||
@@ -373,7 +431,96 @@ renameF [item] _ _ = withErrorDialog $ do
|
|||||||
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
|
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
|
||||||
P.</> fn) ++ "\"?"
|
P.</> fn) ++ "\"?"
|
||||||
withConfirmationDialog cmsg $
|
withConfirmationDialog cmsg $
|
||||||
HSFM.FileSystem.FileOperations.renameFile item fn
|
HSFM.FileSystem.FileOperations.renameFile (path item)
|
||||||
|
((P.dirname $ path item) P.</> fn)
|
||||||
renameF _ _ _ = withErrorDialog
|
renameF _ _ _ = withErrorDialog
|
||||||
. throw $ InvalidOperation
|
. throw $ InvalidOperation
|
||||||
"Operation not supported on multiple files"
|
"Operation not supported on multiple files"
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
|
||||||
|
|
||||||
|
|
||||||
|
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
||||||
|
-- treeView.
|
||||||
|
--
|
||||||
|
-- If the url is invalid, does nothing.
|
||||||
|
urlGoTo :: MyGUI -> MyView -> IO ()
|
||||||
|
urlGoTo mygui myview = withErrorDialog $ do
|
||||||
|
fp <- entryGetText (urlBar myview)
|
||||||
|
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
||||||
|
whenM (canOpenDirectory fp')
|
||||||
|
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||||
|
|
||||||
|
|
||||||
|
goHome :: MyGUI -> MyView -> IO ()
|
||||||
|
goHome mygui myview = withErrorDialog $ do
|
||||||
|
mhomedir <- getEnv "HOME"
|
||||||
|
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
|
||||||
|
whenM (canOpenDirectory fp')
|
||||||
|
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||||
|
|
||||||
|
|
||||||
|
-- |Execute a given file.
|
||||||
|
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
|
execute [item] _ _ = withErrorDialog $
|
||||||
|
void $ executeFile (path item) []
|
||||||
|
execute _ _ _ = withErrorDialog
|
||||||
|
. throw $ InvalidOperation
|
||||||
|
"Operation not supported on multiple files"
|
||||||
|
|
||||||
|
|
||||||
|
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
||||||
|
open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
|
open [item] mygui myview = withErrorDialog $
|
||||||
|
case item of
|
||||||
|
DirOrSym r -> do
|
||||||
|
nv <- readFile getFileInfo $ path r
|
||||||
|
goDir mygui myview nv
|
||||||
|
r ->
|
||||||
|
void $ openFile . path $ r
|
||||||
|
-- this throws on the first error that occurs
|
||||||
|
open (FileLikeList fs) _ _ = withErrorDialog $
|
||||||
|
forM_ fs $ \f -> void $ openFile . path $ f
|
||||||
|
open _ _ _ = withErrorDialog
|
||||||
|
. throw $ InvalidOperation
|
||||||
|
"Operation not supported on multiple files"
|
||||||
|
|
||||||
|
|
||||||
|
-- |Go up one directory and visualize it in the treeView.
|
||||||
|
upDir :: MyGUI -> MyView -> IO ()
|
||||||
|
upDir mygui myview = withErrorDialog $ do
|
||||||
|
cdir <- getCurrentDir myview
|
||||||
|
nv <- goUp cdir
|
||||||
|
goDir mygui myview nv
|
||||||
|
|
||||||
|
|
||||||
|
-- |Go "back" in the history.
|
||||||
|
goHistoryPrev :: MyGUI -> MyView -> IO ()
|
||||||
|
goHistoryPrev mygui myview = do
|
||||||
|
hs <- readTVarIO (history myview)
|
||||||
|
case hs of
|
||||||
|
([], _) -> return ()
|
||||||
|
(x:xs, _) -> do
|
||||||
|
cdir <- getCurrentDir myview
|
||||||
|
nv <- readFile getFileInfo $ x
|
||||||
|
modifyTVarIO (history myview)
|
||||||
|
(\(_, n) -> (xs, path cdir `addHistory` n))
|
||||||
|
refreshView' mygui myview nv
|
||||||
|
|
||||||
|
|
||||||
|
-- |Go "forth" in the history.
|
||||||
|
goHistoryNext :: MyGUI -> MyView -> IO ()
|
||||||
|
goHistoryNext mygui myview = do
|
||||||
|
hs <- readTVarIO (history myview)
|
||||||
|
case hs of
|
||||||
|
(_, []) -> return ()
|
||||||
|
(_, x:xs) -> do
|
||||||
|
cdir <- getCurrentDir myview
|
||||||
|
nv <- readFile getFileInfo $ x
|
||||||
|
modifyTVarIO (history myview)
|
||||||
|
(\(p, _) -> (path cdir `addHistory` p, xs))
|
||||||
|
refreshView' mygui myview nv
|
||||||
|
|
||||||
|
|||||||
@@ -22,4 +22,4 @@ module HSFM.GUI.Gtk.Callbacks where
|
|||||||
import HSFM.GUI.Gtk.Data
|
import HSFM.GUI.Gtk.Data
|
||||||
|
|
||||||
|
|
||||||
setCallbacks :: MyGUI -> MyView -> IO ()
|
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
||||||
|
|||||||
102
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
Normal file
102
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
Normal file
@@ -0,0 +1,102 @@
|
|||||||
|
{--
|
||||||
|
HSFM, a filemanager written in Haskell.
|
||||||
|
Copyright (C) 2016 Julian Ospald
|
||||||
|
|
||||||
|
This program is free software; you can redistribute it and/or
|
||||||
|
modify it under the terms of the GNU General Public License
|
||||||
|
version 2 as published by the Free Software Foundation.
|
||||||
|
|
||||||
|
This program is distributed in the hope that it will be useful,
|
||||||
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
GNU General Public License for more details.
|
||||||
|
|
||||||
|
You should have received a copy of the GNU General Public License
|
||||||
|
along with this program; if not, write to the Free Software
|
||||||
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||||
|
--}
|
||||||
|
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
|
module HSFM.GUI.Gtk.Callbacks.Utils where
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
import Control.Monad
|
||||||
|
(
|
||||||
|
forM_
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import qualified HPath as P
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import HSFM.FileSystem.FileOperations
|
||||||
|
import HSFM.FileSystem.FileType
|
||||||
|
import HSFM.FileSystem.UtilTypes
|
||||||
|
import HSFM.GUI.Gtk.Data
|
||||||
|
import HSFM.GUI.Gtk.Dialogs
|
||||||
|
import HSFM.GUI.Gtk.MyView
|
||||||
|
import HSFM.GUI.Gtk.Utils
|
||||||
|
import HSFM.Utils.IO
|
||||||
|
(
|
||||||
|
modifyTVarIO
|
||||||
|
)
|
||||||
|
import Prelude hiding(readFile)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- |Carries out a file operation with the appropriate error handling
|
||||||
|
-- allowing the user to react to various exceptions with further input.
|
||||||
|
doFileOperation :: FileOperation -> IO ()
|
||||||
|
doFileOperation (FCopy (Copy (f':fs') to)) =
|
||||||
|
_doFileOperation (f':fs') to easyCopyOverwrite easyCopy
|
||||||
|
$ doFileOperation (FCopy $ Copy fs' to)
|
||||||
|
doFileOperation (FMove (Move (f':fs') to)) =
|
||||||
|
_doFileOperation (f':fs') to moveFileOverwrite moveFile
|
||||||
|
$ doFileOperation (FMove $ Move fs' to)
|
||||||
|
where
|
||||||
|
|
||||||
|
doFileOperation _ = return ()
|
||||||
|
|
||||||
|
|
||||||
|
_doFileOperation :: [P.Path b1]
|
||||||
|
-> P.Path P.Abs
|
||||||
|
-> (P.Path b1 -> P.Path P.Abs -> IO b)
|
||||||
|
-> (P.Path b1 -> P.Path P.Abs -> IO a)
|
||||||
|
-> IO ()
|
||||||
|
-> IO ()
|
||||||
|
_doFileOperation [] _ _ _ _ = return ()
|
||||||
|
_doFileOperation (f:fs) to mcOverwrite mc rest = do
|
||||||
|
toname <- P.basename f
|
||||||
|
let topath = to P.</> toname
|
||||||
|
reactOnError (mc f topath >> rest)
|
||||||
|
[(AlreadyExists , collisionAction fileCollisionDialog topath)]
|
||||||
|
[(FileDoesExist{}, collisionAction fileCollisionDialog topath)
|
||||||
|
,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
|
||||||
|
,(SameFile{} , collisionAction renameDialog topath)]
|
||||||
|
where
|
||||||
|
collisionAction diag topath = do
|
||||||
|
mcm <- diag . P.fromAbs $ topath
|
||||||
|
forM_ mcm $ \cm -> case cm of
|
||||||
|
Overwrite -> mcOverwrite f topath >> rest
|
||||||
|
OverwriteAll -> forM_ (f:fs) $ \x -> do
|
||||||
|
toname' <- P.basename x
|
||||||
|
mcOverwrite x (to P.</> toname')
|
||||||
|
Skip -> rest
|
||||||
|
Rename newn -> mc f (to P.</> newn) >> rest
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
|
||||||
|
-- |Helper that is invoked for any directory change operations.
|
||||||
|
goDir :: MyGUI -> MyView -> Item -> IO ()
|
||||||
|
goDir mygui myview item = do
|
||||||
|
cdir <- getCurrentDir myview
|
||||||
|
modifyTVarIO (history myview)
|
||||||
|
(\(p, _) -> (path cdir `addHistory` p, []))
|
||||||
|
refreshView' mygui myview item
|
||||||
|
|
||||||
@@ -29,10 +29,15 @@ import Control.Concurrent.STM
|
|||||||
(
|
(
|
||||||
TVar
|
TVar
|
||||||
)
|
)
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk hiding (MenuBar)
|
||||||
import HSFM.FileSystem.FileOperations
|
import HPath
|
||||||
|
(
|
||||||
|
Abs
|
||||||
|
, Path
|
||||||
|
)
|
||||||
import HSFM.FileSystem.FileType
|
import HSFM.FileSystem.FileType
|
||||||
import System.INotify.ByteString
|
import HSFM.FileSystem.UtilTypes
|
||||||
|
import System.INotify
|
||||||
(
|
(
|
||||||
INotify
|
INotify
|
||||||
)
|
)
|
||||||
@@ -50,65 +55,96 @@ import System.INotify.ByteString
|
|||||||
-- runtime.
|
-- runtime.
|
||||||
data MyGUI = MkMyGUI {
|
data MyGUI = MkMyGUI {
|
||||||
-- |main Window
|
-- |main Window
|
||||||
rootWin :: Window
|
rootWin :: !Window
|
||||||
, menubarFileQuit :: ImageMenuItem
|
|
||||||
, menubarFileOpen :: ImageMenuItem
|
-- widgets on the main window
|
||||||
, menubarFileExecute :: ImageMenuItem
|
, menubar :: !MenuBar
|
||||||
, menubarFileNew :: ImageMenuItem
|
, statusBar :: !Statusbar
|
||||||
, menubarEditCut :: ImageMenuItem
|
, clearStatusBar :: !Button
|
||||||
, menubarEditCopy :: ImageMenuItem
|
, notebook :: !Notebook
|
||||||
, menubarEditRename :: ImageMenuItem
|
|
||||||
, menubarEditPaste :: ImageMenuItem
|
-- other
|
||||||
, menubarEditDelete :: ImageMenuItem
|
, fprop :: !FilePropertyGrid
|
||||||
, menubarViewTree :: ImageMenuItem
|
, settings :: !(TVar FMSettings)
|
||||||
, menubarViewIcon :: ImageMenuItem
|
|
||||||
, menubarHelpAbout :: ImageMenuItem
|
, operationBuffer :: !(TVar FileOperation)
|
||||||
, rcMenu :: Menu
|
}
|
||||||
, rcFileOpen :: ImageMenuItem
|
|
||||||
, rcFileExecute :: ImageMenuItem
|
|
||||||
, rcFileNew :: ImageMenuItem
|
-- |This describes the contents of the current view and is separated from MyGUI,
|
||||||
, rcFileCut :: ImageMenuItem
|
-- because we might want to have multiple views.
|
||||||
, rcFileCopy :: ImageMenuItem
|
data MyView = MkMyView {
|
||||||
, rcFileRename :: ImageMenuItem
|
view :: !(TVar FMView)
|
||||||
, rcFilePaste :: ImageMenuItem
|
, cwd :: !(MVar Item)
|
||||||
, rcFileDelete :: ImageMenuItem
|
, rawModel :: !(TVar (ListStore Item))
|
||||||
, upViewB :: Button
|
, sortedModel :: !(TVar (TypedTreeModelSort Item))
|
||||||
, homeViewB :: Button
|
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
|
||||||
, refreshViewB :: Button
|
, inotify :: !(MVar INotify)
|
||||||
, urlBar :: Entry
|
|
||||||
, statusBar :: Statusbar
|
-- the first part of the tuple represents the "go back"
|
||||||
, clearStatusBar :: Button
|
-- the second part the "go forth" in the history
|
||||||
, settings :: TVar FMSettings
|
, history :: !(TVar ([Path Abs], [Path Abs]))
|
||||||
, scroll :: ScrolledWindow
|
|
||||||
|
-- sub-widgets
|
||||||
|
, scroll :: !ScrolledWindow
|
||||||
|
, viewBox :: !Box
|
||||||
|
, rcmenu :: !RightClickMenu
|
||||||
|
, upViewB :: !Button
|
||||||
|
, homeViewB :: !Button
|
||||||
|
, refreshViewB :: !Button
|
||||||
|
, urlBar :: !Entry
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
data MenuBar = MkMenuBar {
|
||||||
|
menubarFileQuit :: !ImageMenuItem
|
||||||
|
, menubarHelpAbout :: !ImageMenuItem
|
||||||
|
}
|
||||||
|
|
||||||
|
data RightClickMenu = MkRightClickMenu {
|
||||||
|
rcMenu :: !Menu
|
||||||
|
, rcFileOpen :: !ImageMenuItem
|
||||||
|
, rcFileExecute :: !ImageMenuItem
|
||||||
|
, rcFileNewRegFile :: !ImageMenuItem
|
||||||
|
, rcFileNewDir :: !ImageMenuItem
|
||||||
|
, rcFileCut :: !ImageMenuItem
|
||||||
|
, rcFileCopy :: !ImageMenuItem
|
||||||
|
, rcFileRename :: !ImageMenuItem
|
||||||
|
, rcFilePaste :: !ImageMenuItem
|
||||||
|
, rcFileDelete :: !ImageMenuItem
|
||||||
|
, rcFileProperty :: !ImageMenuItem
|
||||||
|
, rcFileIconView :: !ImageMenuItem
|
||||||
|
, rcFileTreeView :: !ImageMenuItem
|
||||||
|
}
|
||||||
|
|
||||||
|
data FilePropertyGrid = MkFilePropertyGrid {
|
||||||
|
fpropGrid :: !Grid
|
||||||
|
, fpropFnEntry :: !Entry
|
||||||
|
, fpropLocEntry :: !Entry
|
||||||
|
, fpropTsEntry :: !Entry
|
||||||
|
, fpropModEntry :: !Entry
|
||||||
|
, fpropAcEntry :: !Entry
|
||||||
|
, fpropFTEntry :: !Entry
|
||||||
|
, fpropPermEntry :: !Entry
|
||||||
|
, fpropLDEntry :: !Entry
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
-- |FM-wide settings.
|
-- |FM-wide settings.
|
||||||
data FMSettings = MkFMSettings {
|
data FMSettings = MkFMSettings {
|
||||||
showHidden :: Bool
|
showHidden :: !Bool
|
||||||
, isLazy :: Bool
|
, isLazy :: !Bool
|
||||||
, iconSize :: Int
|
, iconSize :: !Int
|
||||||
}
|
}
|
||||||
|
|
||||||
data FMView = FMTreeView TreeView
|
data FMView = FMTreeView !TreeView
|
||||||
| FMIconView IconView
|
| FMIconView !IconView
|
||||||
|
|
||||||
type Item = File FileInfo
|
type Item = File FileInfo
|
||||||
|
|
||||||
|
|
||||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
|
||||||
-- because we might want to have multiple views.
|
|
||||||
data MyView = MkMyView {
|
|
||||||
view :: TVar FMView
|
|
||||||
, cwd :: MVar Item
|
|
||||||
, rawModel :: TVar (ListStore Item)
|
|
||||||
, sortedModel :: TVar (TypedTreeModelSort Item)
|
|
||||||
, filteredModel :: TVar (TypedTreeModelFilter Item)
|
|
||||||
, operationBuffer :: TVar FileOperation
|
|
||||||
, inotify :: MVar INotify
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
fmViewToContainer :: FMView -> Container
|
fmViewToContainer :: FMView -> Container
|
||||||
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
|
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
|
||||||
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x
|
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x
|
||||||
|
|
||||||
|
|||||||
@@ -23,8 +23,7 @@ module HSFM.GUI.Gtk.Dialogs where
|
|||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
(
|
(
|
||||||
catch
|
displayException
|
||||||
, displayException
|
|
||||||
, throw
|
, throw
|
||||||
, IOException
|
, IOException
|
||||||
, catches
|
, catches
|
||||||
@@ -36,6 +35,15 @@ import Control.Monad
|
|||||||
, when
|
, when
|
||||||
, void
|
, void
|
||||||
)
|
)
|
||||||
|
import Data.ByteString
|
||||||
|
(
|
||||||
|
ByteString
|
||||||
|
)
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8
|
||||||
|
(
|
||||||
|
fromString
|
||||||
|
)
|
||||||
import Data.Version
|
import Data.Version
|
||||||
(
|
(
|
||||||
showVersion
|
showVersion
|
||||||
@@ -61,12 +69,27 @@ import Distribution.Verbosity
|
|||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
import HSFM.FileSystem.Errors
|
import HSFM.FileSystem.Errors
|
||||||
import HSFM.FileSystem.FileOperations
|
import HSFM.FileSystem.FileType
|
||||||
|
import HSFM.FileSystem.UtilTypes
|
||||||
|
import HSFM.GUI.Glib.GlibString()
|
||||||
|
import HSFM.GUI.Gtk.Data
|
||||||
import HSFM.GUI.Gtk.Errors
|
import HSFM.GUI.Gtk.Errors
|
||||||
import Paths_hsfm
|
import Paths_hsfm
|
||||||
(
|
(
|
||||||
getDataFileName
|
getDataFileName
|
||||||
)
|
)
|
||||||
|
import System.Glib.UTFString
|
||||||
|
(
|
||||||
|
GlibString
|
||||||
|
)
|
||||||
|
import System.Posix.FilePath
|
||||||
|
(
|
||||||
|
takeFileName
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -104,83 +127,65 @@ showConfirmationDialog str = do
|
|||||||
_ -> return False
|
_ -> return False
|
||||||
|
|
||||||
|
|
||||||
-- |Asks the user which directory copy mode he wants via dialog popup
|
fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
|
||||||
-- and returns 'DirCopyMode'. Default is always Strict, so this allows
|
fileCollisionDialog t = do
|
||||||
-- switching to Merge/Replace/Rename.
|
|
||||||
showCopyModeDialog :: IO (Maybe CopyMode)
|
|
||||||
showCopyModeDialog = do
|
|
||||||
chooserDialog <- messageDialogNew Nothing
|
chooserDialog <- messageDialogNew Nothing
|
||||||
[DialogDestroyWithParent]
|
[DialogDestroyWithParent]
|
||||||
MessageQuestion
|
MessageQuestion
|
||||||
ButtonsNone
|
ButtonsNone
|
||||||
"Target exists, how to proceed?"
|
(fromString "Target \"" `BS.append`
|
||||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
t `BS.append`
|
||||||
_ <- dialogAddButton chooserDialog "Merge" (ResponseUser 1)
|
fromString "\" exists, how to proceed?")
|
||||||
_ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
|
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 3)
|
_ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1)
|
||||||
|
_ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
|
||||||
|
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 3)
|
||||||
|
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 4)
|
||||||
rID <- dialogRun chooserDialog
|
rID <- dialogRun chooserDialog
|
||||||
widgetDestroy chooserDialog
|
widgetDestroy chooserDialog
|
||||||
case rID of
|
case rID of
|
||||||
ResponseUser 0 -> return Nothing
|
ResponseUser 0 -> return Nothing
|
||||||
ResponseUser 1 -> return (Just Merge)
|
ResponseUser 1 -> return (Just Overwrite)
|
||||||
ResponseUser 2 -> return (Just Replace)
|
ResponseUser 2 -> return (Just OverwriteAll)
|
||||||
ResponseUser 3 -> do
|
ResponseUser 3 -> return (Just Skip)
|
||||||
mfn <- textInputDialog "Enter new name"
|
ResponseUser 4 -> do
|
||||||
|
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
|
||||||
forM mfn $ \fn -> do
|
forM mfn $ \fn -> do
|
||||||
pfn <- P.parseFn (P.userStringToFP fn)
|
pfn <- P.parseFn (P.userStringToFP fn)
|
||||||
return $ Rename pfn
|
return $ Rename pfn
|
||||||
_ -> throw UnknownDialogButton
|
_ -> throw UnknownDialogButton
|
||||||
|
|
||||||
|
|
||||||
-- |Stipped version of `showCopyModeDialog` that only allows cancelling
|
renameDialog :: ByteString -> IO (Maybe FCollisonMode)
|
||||||
-- or Renaming.
|
renameDialog t = do
|
||||||
showRenameDialog :: IO (Maybe CopyMode)
|
|
||||||
showRenameDialog = do
|
|
||||||
chooserDialog <- messageDialogNew Nothing
|
chooserDialog <- messageDialogNew Nothing
|
||||||
[DialogDestroyWithParent]
|
[DialogDestroyWithParent]
|
||||||
MessageQuestion
|
MessageQuestion
|
||||||
ButtonsNone
|
ButtonsNone
|
||||||
"Target exists, how to proceed?"
|
(fromString "Target \"" `BS.append`
|
||||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
t `BS.append`
|
||||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 1)
|
fromString "\" exists, how to proceed?")
|
||||||
|
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||||
|
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 1)
|
||||||
|
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 2)
|
||||||
rID <- dialogRun chooserDialog
|
rID <- dialogRun chooserDialog
|
||||||
widgetDestroy chooserDialog
|
widgetDestroy chooserDialog
|
||||||
case rID of
|
case rID of
|
||||||
ResponseUser 0 -> return Nothing
|
ResponseUser 0 -> return Nothing
|
||||||
ResponseUser 1 -> do
|
ResponseUser 1 -> return (Just Skip)
|
||||||
mfn <- textInputDialog "Enter new name"
|
ResponseUser 2 -> do
|
||||||
|
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
|
||||||
forM mfn $ \fn -> do
|
forM mfn $ \fn -> do
|
||||||
pfn <- P.parseFn (P.userStringToFP fn)
|
pfn <- P.parseFn (P.userStringToFP fn)
|
||||||
return $ Rename pfn
|
return $ Rename pfn
|
||||||
_ -> throw UnknownDialogButton
|
_ -> throw UnknownDialogButton
|
||||||
|
|
||||||
|
|
||||||
-- |Attempts to run the given function with the `Strict` copy mode.
|
|
||||||
-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
|
|
||||||
-- the user for action via `showCopyModeDialog` and then carries out
|
|
||||||
-- the given function again.
|
|
||||||
withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
|
|
||||||
withCopyModeDialog fa =
|
|
||||||
catch (fa Strict) $ \e ->
|
|
||||||
case e of
|
|
||||||
FileDoesExist _ -> doIt showCopyModeDialog
|
|
||||||
DirDoesExist _ -> doIt showCopyModeDialog
|
|
||||||
SameFile _ _ -> doIt showRenameDialog
|
|
||||||
e' -> throw e'
|
|
||||||
where
|
|
||||||
doIt getCm = do
|
|
||||||
mcm <- getCm
|
|
||||||
case mcm of
|
|
||||||
(Just Strict) -> return () -- don't try again
|
|
||||||
(Just cm) -> fa cm
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
|
|
||||||
-- |Shows the about dialog from the help menu.
|
-- |Shows the about dialog from the help menu.
|
||||||
showAboutDialog :: IO ()
|
showAboutDialog :: IO ()
|
||||||
showAboutDialog = do
|
showAboutDialog = do
|
||||||
ad <- aboutDialogNew
|
ad <- aboutDialogNew
|
||||||
lstr <- readFile =<< getDataFileName "LICENSE"
|
lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
|
||||||
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
||||||
pdesc <- fmap packageDescription
|
pdesc <- fmap packageDescription
|
||||||
(readPackageDescription silent
|
(readPackageDescription silent
|
||||||
@@ -223,14 +228,18 @@ withErrorDialog io =
|
|||||||
|
|
||||||
-- |Asks the user which directory copy mode he wants via dialog popup
|
-- |Asks the user which directory copy mode he wants via dialog popup
|
||||||
-- and returns 'DirCopyMode'.
|
-- and returns 'DirCopyMode'.
|
||||||
textInputDialog :: String -> IO (Maybe String)
|
textInputDialog :: GlibString string
|
||||||
textInputDialog title = do
|
=> string -- ^ window title
|
||||||
|
-> string -- ^ initial text in input widget
|
||||||
|
-> IO (Maybe String)
|
||||||
|
textInputDialog title inittext = do
|
||||||
chooserDialog <- messageDialogNew Nothing
|
chooserDialog <- messageDialogNew Nothing
|
||||||
[DialogDestroyWithParent]
|
[DialogDestroyWithParent]
|
||||||
MessageQuestion
|
MessageQuestion
|
||||||
ButtonsNone
|
ButtonsNone
|
||||||
title
|
title
|
||||||
entry <- entryNew
|
entry <- entryNew
|
||||||
|
entrySetText entry inittext
|
||||||
cbox <- dialogGetActionArea chooserDialog
|
cbox <- dialogGetActionArea chooserDialog
|
||||||
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
|
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
|
||||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
|
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
|
||||||
@@ -244,3 +253,50 @@ textInputDialog title = do
|
|||||||
_ -> throw UnknownDialogButton
|
_ -> throw UnknownDialogButton
|
||||||
widgetDestroy chooserDialog
|
widgetDestroy chooserDialog
|
||||||
return ret
|
return ret
|
||||||
|
|
||||||
|
|
||||||
|
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
|
||||||
|
showFilePropertyDialog [item] mygui _ = do
|
||||||
|
dialog <- messageDialogNew Nothing
|
||||||
|
[DialogDestroyWithParent]
|
||||||
|
MessageInfo
|
||||||
|
ButtonsNone
|
||||||
|
"File Properties"
|
||||||
|
|
||||||
|
let fprop' = fprop mygui
|
||||||
|
grid = fpropGrid fprop'
|
||||||
|
|
||||||
|
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
|
||||||
|
$ P.basename . path $ item)
|
||||||
|
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
|
||||||
|
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
|
||||||
|
entrySetText (fpropModEntry fprop') (packModTime item)
|
||||||
|
entrySetText (fpropAcEntry fprop') (packAccessTime item)
|
||||||
|
entrySetText (fpropFTEntry fprop') (packFileType item)
|
||||||
|
entrySetText (fpropPermEntry fprop')
|
||||||
|
(tail $ packPermissions item) -- throw away the filetype part
|
||||||
|
case packLinkDestination item of
|
||||||
|
(Just dest) -> do
|
||||||
|
widgetSetSensitive (fpropLDEntry fprop') True
|
||||||
|
entrySetText (fpropLDEntry fprop') dest
|
||||||
|
Nothing -> do
|
||||||
|
widgetSetSensitive (fpropLDEntry fprop') False
|
||||||
|
entrySetText (fpropLDEntry fprop') "( Not a symlink )"
|
||||||
|
|
||||||
|
|
||||||
|
cbox <- dialogGetActionArea dialog
|
||||||
|
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
|
||||||
|
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
|
||||||
|
boxPackStart (castToBox cbox) grid PackNatural 5
|
||||||
|
|
||||||
|
widgetShowAll dialog
|
||||||
|
_ <- dialogRun dialog
|
||||||
|
|
||||||
|
-- make sure our grid does not get destroyed
|
||||||
|
containerRemove (castToBox cbox) grid
|
||||||
|
|
||||||
|
widgetDestroy dialog
|
||||||
|
|
||||||
|
return ()
|
||||||
|
showFilePropertyDialog _ _ _ = return ()
|
||||||
|
|
||||||
|
|||||||
@@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
|
|||||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||||
--}
|
--}
|
||||||
|
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
module HSFM.GUI.Gtk.MyGUI where
|
module HSFM.GUI.Gtk.MyGUI where
|
||||||
@@ -26,6 +27,7 @@ import Control.Concurrent.STM
|
|||||||
newTVarIO
|
newTVarIO
|
||||||
)
|
)
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
|
import HSFM.FileSystem.UtilTypes
|
||||||
import HSFM.GUI.Gtk.Data
|
import HSFM.GUI.Gtk.Data
|
||||||
import Paths_hsfm
|
import Paths_hsfm
|
||||||
(
|
(
|
||||||
@@ -46,6 +48,7 @@ createMyGUI = do
|
|||||||
|
|
||||||
let settings' = MkFMSettings False True 24
|
let settings' = MkFMSettings False True 24
|
||||||
settings <- newTVarIO settings'
|
settings <- newTVarIO settings'
|
||||||
|
operationBuffer <- newTVarIO None
|
||||||
|
|
||||||
builder <- builderNew
|
builder <- builderNew
|
||||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||||
@@ -53,64 +56,38 @@ createMyGUI = do
|
|||||||
-- get the pre-defined gui widgets
|
-- get the pre-defined gui widgets
|
||||||
rootWin <- builderGetObject builder castToWindow
|
rootWin <- builderGetObject builder castToWindow
|
||||||
"rootWin"
|
"rootWin"
|
||||||
scroll <- builderGetObject builder castToScrolledWindow
|
|
||||||
"mainScroll"
|
|
||||||
menubarFileQuit <- builderGetObject builder castToImageMenuItem
|
menubarFileQuit <- builderGetObject builder castToImageMenuItem
|
||||||
"menubarFileQuit"
|
"menubarFileQuit"
|
||||||
menubarFileOpen <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileOpen"
|
|
||||||
menubarFileExecute <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileExecute"
|
|
||||||
menubarFileNew <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarFileNew"
|
|
||||||
menubarEditCut <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarEditCut"
|
|
||||||
menubarEditCopy <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarEditCopy"
|
|
||||||
menubarEditRename <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarEditRename"
|
|
||||||
menubarEditPaste <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarEditPaste"
|
|
||||||
menubarEditDelete <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarEditDelete"
|
|
||||||
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
menubarHelpAbout <- builderGetObject builder castToImageMenuItem
|
||||||
"menubarHelpAbout"
|
"menubarHelpAbout"
|
||||||
urlBar <- builderGetObject builder castToEntry
|
|
||||||
"urlBar"
|
|
||||||
statusBar <- builderGetObject builder castToStatusbar
|
statusBar <- builderGetObject builder castToStatusbar
|
||||||
"statusBar"
|
"statusBar"
|
||||||
clearStatusBar <- builderGetObject builder castToButton
|
clearStatusBar <- builderGetObject builder castToButton
|
||||||
"clearStatusBar"
|
"clearStatusBar"
|
||||||
rcMenu <- builderGetObject builder castToMenu
|
fpropGrid <- builderGetObject builder castToGrid
|
||||||
"rcMenu"
|
"fpropGrid"
|
||||||
rcFileOpen <- builderGetObject builder castToImageMenuItem
|
fpropFnEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileOpen"
|
"fpropFnEntry"
|
||||||
rcFileExecute <- builderGetObject builder castToImageMenuItem
|
fpropLocEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileExecute"
|
"fpropLocEntry"
|
||||||
rcFileNew <- builderGetObject builder castToImageMenuItem
|
fpropTsEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileNew"
|
"fpropTsEntry"
|
||||||
rcFileCut <- builderGetObject builder castToImageMenuItem
|
fpropModEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileCut"
|
"fpropModEntry"
|
||||||
rcFileCopy <- builderGetObject builder castToImageMenuItem
|
fpropAcEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileCopy"
|
"fpropAcEntry"
|
||||||
rcFileRename <- builderGetObject builder castToImageMenuItem
|
fpropFTEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileRename"
|
"fpropFTEntry"
|
||||||
rcFilePaste <- builderGetObject builder castToImageMenuItem
|
fpropPermEntry <- builderGetObject builder castToEntry
|
||||||
"rcFilePaste"
|
"fpropPermEntry"
|
||||||
rcFileDelete <- builderGetObject builder castToImageMenuItem
|
fpropLDEntry <- builderGetObject builder castToEntry
|
||||||
"rcFileDelete"
|
"fpropLDEntry"
|
||||||
upViewB <- builderGetObject builder castToButton
|
notebook <- builderGetObject builder castToNotebook
|
||||||
"upViewB"
|
"notebook"
|
||||||
homeViewB <- builderGetObject builder castToButton
|
|
||||||
"homeViewB"
|
|
||||||
refreshViewB <- builderGetObject builder castToButton
|
|
||||||
"refreshViewB"
|
|
||||||
menubarViewTree <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarViewTree"
|
|
||||||
menubarViewIcon <- builderGetObject builder castToImageMenuItem
|
|
||||||
"menubarViewIcon"
|
|
||||||
|
|
||||||
-- construct the gui object
|
-- construct the gui object
|
||||||
|
let menubar = MkMenuBar {..}
|
||||||
|
let fprop = MkFilePropertyGrid {..}
|
||||||
let mygui = MkMyGUI {..}
|
let mygui = MkMyGUI {..}
|
||||||
|
|
||||||
-- sets the default icon
|
-- sets the default icon
|
||||||
|
|||||||
@@ -16,8 +16,6 @@ along with this program; if not, write to the Free Software
|
|||||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||||
--}
|
--}
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
||||||
|
|
||||||
|
|
||||||
module HSFM.GUI.Gtk.MyView where
|
module HSFM.GUI.Gtk.MyView where
|
||||||
@@ -48,36 +46,48 @@ import Data.Maybe
|
|||||||
catMaybes
|
catMaybes
|
||||||
, fromJust
|
, fromJust
|
||||||
)
|
)
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
(
|
||||||
|
canOpenDirectory
|
||||||
|
)
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
|
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
||||||
import HPath
|
import HPath
|
||||||
(
|
(
|
||||||
Path
|
Path
|
||||||
, Abs
|
, Abs
|
||||||
)
|
)
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
import HSFM.FileSystem.FileOperations
|
|
||||||
import HSFM.FileSystem.FileType
|
import HSFM.FileSystem.FileType
|
||||||
import HSFM.GUI.Glib.GlibString()
|
import HSFM.GUI.Glib.GlibString()
|
||||||
import HSFM.GUI.Gtk.Data
|
import HSFM.GUI.Gtk.Data
|
||||||
import HSFM.GUI.Gtk.Icons
|
import HSFM.GUI.Gtk.Icons
|
||||||
import HSFM.GUI.Gtk.Utils
|
import HSFM.GUI.Gtk.Utils
|
||||||
import HSFM.Utils.IO
|
import HSFM.Utils.IO
|
||||||
|
import Paths_hsfm
|
||||||
|
(
|
||||||
|
getDataFileName
|
||||||
|
)
|
||||||
import Prelude hiding(readFile)
|
import Prelude hiding(readFile)
|
||||||
import System.INotify.ByteString
|
import System.INotify
|
||||||
(
|
(
|
||||||
addWatch
|
addWatch
|
||||||
, initINotify
|
, initINotify
|
||||||
, killINotify
|
, killINotify
|
||||||
, EventVariety(..)
|
, EventVariety(..)
|
||||||
)
|
)
|
||||||
import System.IO.Error
|
|
||||||
(
|
|
||||||
tryIOError
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- |Creates a new tab with its own view and refreshes the view.
|
||||||
|
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
|
||||||
|
newTab mygui iofmv path = do
|
||||||
|
myview <- createMyView mygui iofmv
|
||||||
|
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
|
||||||
|
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
|
||||||
|
refreshView mygui myview (Just path)
|
||||||
|
return myview
|
||||||
|
|
||||||
|
|
||||||
-- |Constructs the initial MyView object with a few dummy models.
|
-- |Constructs the initial MyView object with a few dummy models.
|
||||||
-- It also initializes the callbacks.
|
-- It also initializes the callbacks.
|
||||||
@@ -85,9 +95,11 @@ createMyView :: MyGUI
|
|||||||
-> IO FMView
|
-> IO FMView
|
||||||
-> IO MyView
|
-> IO MyView
|
||||||
createMyView mygui iofmv = do
|
createMyView mygui iofmv = do
|
||||||
operationBuffer <- newTVarIO None
|
|
||||||
|
|
||||||
inotify <- newEmptyMVar
|
inotify <- newEmptyMVar
|
||||||
|
history <- newTVarIO ([],[])
|
||||||
|
|
||||||
|
builder <- builderNew
|
||||||
|
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||||
|
|
||||||
-- create dummy models, so we don't have to use MVar
|
-- create dummy models, so we don't have to use MVar
|
||||||
rawModel <- newTVarIO =<< listStoreNew []
|
rawModel <- newTVarIO =<< listStoreNew []
|
||||||
@@ -99,14 +111,56 @@ createMyView mygui iofmv = do
|
|||||||
view' <- iofmv
|
view' <- iofmv
|
||||||
view <- newTVarIO view'
|
view <- newTVarIO view'
|
||||||
|
|
||||||
|
urlBar <- builderGetObject builder castToEntry
|
||||||
|
"urlBar"
|
||||||
|
rcMenu <- builderGetObject builder castToMenu
|
||||||
|
"rcMenu"
|
||||||
|
rcFileOpen <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileOpen"
|
||||||
|
rcFileExecute <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileExecute"
|
||||||
|
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileNewRegFile"
|
||||||
|
rcFileNewDir <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileNewDir"
|
||||||
|
rcFileCut <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileCut"
|
||||||
|
rcFileCopy <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileCopy"
|
||||||
|
rcFileRename <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileRename"
|
||||||
|
rcFilePaste <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFilePaste"
|
||||||
|
rcFileDelete <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileDelete"
|
||||||
|
rcFileProperty <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileProperty"
|
||||||
|
rcFileIconView <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileIconView"
|
||||||
|
rcFileTreeView <- builderGetObject builder castToImageMenuItem
|
||||||
|
"rcFileTreeView"
|
||||||
|
upViewB <- builderGetObject builder castToButton
|
||||||
|
"upViewB"
|
||||||
|
homeViewB <- builderGetObject builder castToButton
|
||||||
|
"homeViewB"
|
||||||
|
refreshViewB <- builderGetObject builder castToButton
|
||||||
|
"refreshViewB"
|
||||||
|
scroll <- builderGetObject builder castToScrolledWindow
|
||||||
|
"mainScroll"
|
||||||
|
viewBox <- builderGetObject builder castToBox
|
||||||
|
"viewBox"
|
||||||
|
|
||||||
|
let rcmenu = MkRightClickMenu {..}
|
||||||
let myview = MkMyView {..}
|
let myview = MkMyView {..}
|
||||||
|
|
||||||
-- set the bindings
|
-- set the bindings
|
||||||
setCallbacks mygui myview
|
setViewCallbacks mygui myview
|
||||||
|
|
||||||
-- add the treeview to the scroll container
|
-- add the treeview to the scroll container
|
||||||
let oview = fmViewToContainer view'
|
let oview = fmViewToContainer view'
|
||||||
containerAdd (scroll mygui) oview
|
containerAdd scroll oview
|
||||||
|
|
||||||
|
widgetShowAll viewBox
|
||||||
|
|
||||||
return myview
|
return myview
|
||||||
|
|
||||||
@@ -115,22 +169,41 @@ createMyView mygui iofmv = do
|
|||||||
-- io action returns.
|
-- io action returns.
|
||||||
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
||||||
switchView mygui myview iofmv = do
|
switchView mygui myview iofmv = do
|
||||||
|
cwd <- getCurrentDir myview
|
||||||
|
|
||||||
|
oldpage <- destroyView mygui myview
|
||||||
|
|
||||||
|
-- create new view and tab page where the previous one was
|
||||||
|
nview <- createMyView mygui iofmv
|
||||||
|
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
|
||||||
|
(maybe (P.fromAbs $ path cwd) P.fromRel
|
||||||
|
$ P.basename . path $ cwd) oldpage
|
||||||
|
notebookSetCurrentPage (notebook mygui) newpage
|
||||||
|
|
||||||
|
refreshView' mygui nview cwd
|
||||||
|
|
||||||
|
|
||||||
|
-- |Destroys the current view by disconnecting the watcher
|
||||||
|
-- and destroying the active FMView container.
|
||||||
|
--
|
||||||
|
-- Everything that needs to be done in order to forget about a
|
||||||
|
-- view needs to be done here.
|
||||||
|
--
|
||||||
|
-- Returns the page in the tab list this view corresponds to.
|
||||||
|
destroyView :: MyGUI -> MyView -> IO Int
|
||||||
|
destroyView mygui myview = do
|
||||||
|
-- disconnect watcher
|
||||||
|
mi <- tryTakeMVar (inotify myview)
|
||||||
|
for_ mi $ \i -> killINotify i
|
||||||
|
|
||||||
|
page <- notebookGetCurrentPage (notebook mygui)
|
||||||
|
|
||||||
|
-- destroy old view and tab page
|
||||||
view' <- readTVarIO $ view myview
|
view' <- readTVarIO $ view myview
|
||||||
let oview = fmViewToContainer view'
|
widgetDestroy (fmViewToContainer view')
|
||||||
|
notebookRemovePage (notebook mygui) page
|
||||||
|
|
||||||
widgetDestroy oview
|
return page
|
||||||
|
|
||||||
nview' <- iofmv
|
|
||||||
let nview = fmViewToContainer nview'
|
|
||||||
|
|
||||||
writeTVarIO (view myview) nview'
|
|
||||||
|
|
||||||
setCallbacks mygui myview
|
|
||||||
|
|
||||||
containerAdd (scroll mygui) nview
|
|
||||||
widgetShow nview
|
|
||||||
|
|
||||||
refreshView mygui myview Nothing
|
|
||||||
|
|
||||||
|
|
||||||
-- |Createss an IconView.
|
-- |Createss an IconView.
|
||||||
@@ -156,6 +229,13 @@ createTreeView = do
|
|||||||
tvs <- treeViewGetSelection treeView
|
tvs <- treeViewGetSelection treeView
|
||||||
treeSelectionSetMode tvs SelectionMultiple
|
treeSelectionSetMode tvs SelectionMultiple
|
||||||
|
|
||||||
|
-- set drag and drop
|
||||||
|
tl <- targetListNew
|
||||||
|
atom <- atomNew ("HSFM" :: String)
|
||||||
|
targetListAdd tl atom [TargetSameApp] 0
|
||||||
|
treeViewEnableModelDragDest treeView tl [ActionCopy]
|
||||||
|
treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
|
||||||
|
|
||||||
-- create final tree model columns
|
-- create final tree model columns
|
||||||
renderTxt <- cellRendererTextNew
|
renderTxt <- cellRendererTextNew
|
||||||
renderPix <- cellRendererPixbufNew
|
renderPix <- cellRendererPixbufNew
|
||||||
@@ -212,16 +292,10 @@ refreshView :: MyGUI
|
|||||||
refreshView mygui myview mfp =
|
refreshView mygui myview mfp =
|
||||||
case mfp of
|
case mfp of
|
||||||
Just fp -> do
|
Just fp -> do
|
||||||
-- readFileWithFileInfo can just outright fail...
|
canopen <- canOpenDirectory fp
|
||||||
ecdir <- tryIOError (readFile getFileInfo fp)
|
if canopen
|
||||||
case ecdir of
|
then refreshView' mygui myview =<< readFile getFileInfo fp
|
||||||
Right cdir ->
|
else refreshView mygui myview =<< getAlternativeDir
|
||||||
-- ...or return an `AnchordFile` with a Failed constructor,
|
|
||||||
-- both of which need to be handled here
|
|
||||||
if (failed cdir)
|
|
||||||
then refreshView mygui myview =<< getAlternativeDir
|
|
||||||
else refreshView' mygui myview cdir
|
|
||||||
Left _ -> refreshView mygui myview =<< getAlternativeDir
|
|
||||||
Nothing -> refreshView mygui myview =<< getAlternativeDir
|
Nothing -> refreshView mygui myview =<< getAlternativeDir
|
||||||
where
|
where
|
||||||
getAlternativeDir = do
|
getAlternativeDir = do
|
||||||
@@ -229,7 +303,7 @@ refreshView mygui myview mfp =
|
|||||||
Item)
|
Item)
|
||||||
case ecd of
|
case ecd of
|
||||||
Right dir -> return (Just $ path dir)
|
Right dir -> return (Just $ path dir)
|
||||||
Left _ -> return (P.parseAbs "/")
|
Left _ -> return (P.parseAbs P.pathSeparator')
|
||||||
|
|
||||||
|
|
||||||
-- |Refreshes the View based on the given directory.
|
-- |Refreshes the View based on the given directory.
|
||||||
@@ -240,14 +314,16 @@ refreshView' :: MyGUI
|
|||||||
-> MyView
|
-> MyView
|
||||||
-> Item
|
-> Item
|
||||||
-> IO ()
|
-> IO ()
|
||||||
refreshView' mygui myview dt@(DirOrSym _) = do
|
refreshView' mygui myview SymLink { sdest = d@Dir{} } =
|
||||||
newRawModel <- fileListStore dt myview
|
refreshView' mygui myview d
|
||||||
|
refreshView' mygui myview item@Dir{} = do
|
||||||
|
newRawModel <- fileListStore item myview
|
||||||
writeTVarIO (rawModel myview) newRawModel
|
writeTVarIO (rawModel myview) newRawModel
|
||||||
|
|
||||||
view' <- readTVarIO $ view myview
|
view' <- readTVarIO $ view myview
|
||||||
|
|
||||||
_ <- tryTakeMVar (cwd myview)
|
_ <- tryTakeMVar (cwd myview)
|
||||||
putMVar (cwd myview) dt
|
putMVar (cwd myview) item
|
||||||
|
|
||||||
-- get selected items
|
-- get selected items
|
||||||
tps <- getSelectedTreePaths mygui myview
|
tps <- getSelectedTreePaths mygui myview
|
||||||
@@ -255,6 +331,12 @@ refreshView' mygui myview dt@(DirOrSym _) = do
|
|||||||
|
|
||||||
constructView mygui myview
|
constructView mygui myview
|
||||||
|
|
||||||
|
-- set notebook tab label
|
||||||
|
page <- notebookGetCurrentPage (notebook mygui)
|
||||||
|
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
|
||||||
|
notebookSetTabLabelText (notebook mygui) child
|
||||||
|
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
|
||||||
|
|
||||||
-- reselect selected items
|
-- reselect selected items
|
||||||
-- TODO: not implemented for icon view yet
|
-- TODO: not implemented for icon view yet
|
||||||
case view' of
|
case view' of
|
||||||
@@ -299,7 +381,7 @@ constructView mygui myview = do
|
|||||||
cdirp <- path <$> getCurrentDir myview
|
cdirp <- path <$> getCurrentDir myview
|
||||||
|
|
||||||
-- update urlBar
|
-- update urlBar
|
||||||
entrySetText (urlBar mygui) (P.fromAbs cdirp)
|
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
||||||
|
|
||||||
rawModel' <- readTVarIO $ rawModel myview
|
rawModel' <- readTVarIO $ rawModel myview
|
||||||
|
|
||||||
|
|||||||
@@ -67,24 +67,7 @@ getSelectedItems :: MyGUI
|
|||||||
-> IO [Item]
|
-> IO [Item]
|
||||||
getSelectedItems mygui myview = do
|
getSelectedItems mygui myview = do
|
||||||
tps <- getSelectedTreePaths mygui myview
|
tps <- getSelectedTreePaths mygui myview
|
||||||
getSelectedItems' mygui myview tps
|
catMaybes <$> mapM (rawPathToItem myview) tps
|
||||||
|
|
||||||
|
|
||||||
getSelectedItems' :: MyGUI
|
|
||||||
-> MyView
|
|
||||||
-> [TreePath]
|
|
||||||
-> IO [Item]
|
|
||||||
getSelectedItems' _ myview tps = do
|
|
||||||
rawModel' <- readTVarIO $ rawModel myview
|
|
||||||
sortedModel' <- readTVarIO $ sortedModel myview
|
|
||||||
filteredModel' <- readTVarIO $ filteredModel myview
|
|
||||||
iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
|
|
||||||
forM iters $ \iter -> do
|
|
||||||
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
|
|
||||||
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
|
|
||||||
treeModelGetRow rawModel' cIter
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- |Carry out an action on the currently selected item.
|
-- |Carry out an action on the currently selected item.
|
||||||
@@ -124,13 +107,14 @@ getFirstItem myview = do
|
|||||||
|
|
||||||
|
|
||||||
-- |Reads the current directory from MyView.
|
-- |Reads the current directory from MyView.
|
||||||
|
--
|
||||||
|
-- This reads the MVar and may block the main thread if it's
|
||||||
|
-- empty.
|
||||||
getCurrentDir :: MyView
|
getCurrentDir :: MyView
|
||||||
-> IO Item
|
-> IO Item
|
||||||
getCurrentDir myview = readMVar (cwd myview)
|
getCurrentDir myview = readMVar (cwd myview)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- |Push a message to the status bar.
|
-- |Push a message to the status bar.
|
||||||
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
|
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
|
||||||
pushStatusBar mygui str = do
|
pushStatusBar mygui str = do
|
||||||
@@ -146,3 +130,37 @@ popStatusbar mygui = do
|
|||||||
let sb = statusBar mygui
|
let sb = statusBar mygui
|
||||||
cid <- statusbarGetContextId sb "FM Status"
|
cid <- statusbarGetContextId sb "FM Status"
|
||||||
statusbarPop sb cid
|
statusbarPop sb cid
|
||||||
|
|
||||||
|
|
||||||
|
-- |Turn a path on the rawModel into a path that we can
|
||||||
|
-- use at the outermost model layer.
|
||||||
|
rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter)
|
||||||
|
rawPathToIter myview tp = do
|
||||||
|
fmodel <- readTVarIO (filteredModel myview)
|
||||||
|
smodel <- readTVarIO (sortedModel myview)
|
||||||
|
msiter <- treeModelGetIter smodel tp
|
||||||
|
forM msiter $ \siter -> do
|
||||||
|
cIter <- treeModelSortConvertIterToChildIter smodel siter
|
||||||
|
treeModelFilterConvertIterToChildIter fmodel cIter
|
||||||
|
|
||||||
|
|
||||||
|
-- |Turn a path on the rawModel into the corresponding item
|
||||||
|
-- that we can use at the outermost model layer.
|
||||||
|
rawPathToItem :: MyView -> TreePath -> IO (Maybe Item)
|
||||||
|
rawPathToItem myview tp = do
|
||||||
|
rawModel' <- readTVarIO $ rawModel myview
|
||||||
|
miter <- rawPathToIter myview tp
|
||||||
|
forM miter $ \iter -> treeModelGetRow rawModel' iter
|
||||||
|
|
||||||
|
|
||||||
|
-- |Makes sure the list is max 5. This is probably not very efficient
|
||||||
|
-- but we don't care, since it's a small list anyway.
|
||||||
|
addHistory :: Eq a => a -> [a] -> [a]
|
||||||
|
addHistory i [] = [i]
|
||||||
|
addHistory i xs@(x:_)
|
||||||
|
| i == x = xs
|
||||||
|
| length xs == maxLength = i : take (maxLength - 1) xs
|
||||||
|
| otherwise = i : xs
|
||||||
|
where
|
||||||
|
maxLength = 10
|
||||||
|
|
||||||
|
|||||||
110
test/FileSystem/FileOperations/CopyDirRecursiveOverwriteSpec.hs
Normal file
110
test/FileSystem/FileOperations/CopyDirRecursiveOverwriteSpec.hs
Normal file
@@ -0,0 +1,110 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import System.Exit
|
||||||
|
import System.Process
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.copyDirRecursiveOverwrite" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "copyDirRecursiveOverwrite, all fine" $ do
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
removeDirIfExists $ specDir `ba` "outputDir"
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, all fine and compare" $ do
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
(system $ "diff -r --no-dereference "
|
||||||
|
++ specDir' ++ "inputDir" ++ " "
|
||||||
|
++ specDir' ++ "outputDir")
|
||||||
|
`shouldReturn` ExitSuccess
|
||||||
|
removeDirIfExists $ specDir `ba` "outputDir"
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, destination dir already exists" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "copyDirRecursiveOverwrite, source directory does not exist" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "doesNotExist")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, no write permission on output dir" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "noWritePerm/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, cannot open output dir" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "noPerms/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, cannot open source dir" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "noPerms/inputDir")
|
||||||
|
(specDir `ba` "foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, destination already exists and is a file" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, wrong input (regular file)" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "wrongInput")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, wrong input (symlink to directory)" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "wrongInputSymL")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
-- custom failures
|
||||||
|
it "copyDirRecursiveOverwrite, destination in source" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "inputDir/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
isDestinationInSource
|
||||||
|
|
||||||
|
it "copyDirRecursiveOverwrite, destination and source same directory" $
|
||||||
|
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "inputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
112
test/FileSystem/FileOperations/CopyDirRecursiveSpec.hs
Normal file
112
test/FileSystem/FileOperations/CopyDirRecursiveSpec.hs
Normal file
@@ -0,0 +1,112 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CopyDirRecursiveSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import System.Exit
|
||||||
|
import System.Process
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/copyDirRecursiveSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.copyDirRecursive" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "copyDirRecursive, all fine" $ do
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
removeDirIfExists (specDir `ba` "outputDir")
|
||||||
|
|
||||||
|
it "copyDirRecursive, all fine and compare" $ do
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
(system $ "diff -r --no-dereference "
|
||||||
|
++ specDir' ++ "inputDir" ++ " "
|
||||||
|
++ specDir' ++ "outputDir")
|
||||||
|
`shouldReturn` ExitSuccess
|
||||||
|
removeDirIfExists (specDir `ba` "outputDir")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "copyDirRecursive, source directory does not exist" $
|
||||||
|
copyDirRecursive' (specDir `ba` "doesNotExist")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "copyDirRecursive, no write permission on output dir" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "noWritePerm/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursive, cannot open output dir" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "noPerms/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursive, cannot open source dir" $
|
||||||
|
copyDirRecursive' (specDir `ba` "noPerms/inputDir")
|
||||||
|
(specDir `ba` "foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyDirRecursive, destination dir already exists" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
it "copyDirRecursive, destination already exists and is a file" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
it "copyDirRecursive, wrong input (regular file)" $
|
||||||
|
copyDirRecursive' (specDir `ba` "wrongInput")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "copyDirRecursive, wrong input (symlink to directory)" $
|
||||||
|
copyDirRecursive' (specDir `ba` "wrongInputSymL")
|
||||||
|
(specDir `ba` "outputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
-- custom failures
|
||||||
|
it "copyDirRecursive, destination in source" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "inputDir/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
isDestinationInSource
|
||||||
|
|
||||||
|
it "copyDirRecursive, destination and source same directory" $
|
||||||
|
copyDirRecursive' (specDir `ba` "inputDir")
|
||||||
|
(specDir `ba` "inputDir")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
109
test/FileSystem/FileOperations/CopyFileOverwriteSpec.hs
Normal file
109
test/FileSystem/FileOperations/CopyFileOverwriteSpec.hs
Normal file
@@ -0,0 +1,109 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CopyFileOverwriteSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import System.Exit
|
||||||
|
import System.Process
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/copyFileOverwriteSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.copyFileOverwrite" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "copyFileOverwrite, everything clear" $ do
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
removeFileIfExists (specDir `ba` "outputFile")
|
||||||
|
|
||||||
|
it "copyFileOverwrite, output file already exists, all clear" $ do
|
||||||
|
copyFile' (specDir `ba` "alreadyExists") (specDir `ba` "alreadyExists.bak")
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
|
||||||
|
++ specDir' ++ "alreadyExists")
|
||||||
|
`shouldReturn` ExitSuccess
|
||||||
|
removeFileIfExists (specDir `ba` "alreadyExists")
|
||||||
|
copyFile' (specDir `ba` "alreadyExists.bak") (specDir `ba` "alreadyExists")
|
||||||
|
removeFileIfExists (specDir `ba` "alreadyExists.bak")
|
||||||
|
|
||||||
|
it "copyFileOverwrite, and compare" $ do
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
|
||||||
|
++ specDir' ++ "outputFile")
|
||||||
|
`shouldReturn` ExitSuccess
|
||||||
|
removeFileIfExists (specDir `ba` "outputFile")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "copyFileOverwrite, input file does not exist" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "noSuchFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, no permission to write to output directory" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputDirNoWrite/outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, cannot open output directory" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "noPerms/outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, cannot open source directory" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "noPerms/inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, wrong input type (symlink)" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFileSymL")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, wrong input type (directory)" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "wrongInput")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "copyFileOverwrite, output file already exists and is a dir" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "copyFileOverwrite, output and input are same file" $
|
||||||
|
copyFileOverwrite' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "inputFile")
|
||||||
|
`shouldThrow` isSameFile
|
||||||
105
test/FileSystem/FileOperations/CopyFileSpec.hs
Normal file
105
test/FileSystem/FileOperations/CopyFileSpec.hs
Normal file
@@ -0,0 +1,105 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CopyFileSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import System.Exit
|
||||||
|
import System.Process
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/copyFileSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.copyFile" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "copyFile, everything clear" $ do
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
removeFileIfExists (specDir `ba` "outputFile")
|
||||||
|
|
||||||
|
it "copyFile, and compare" $ do
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
|
||||||
|
++ specDir' ++ "outputFile")
|
||||||
|
`shouldReturn` ExitSuccess
|
||||||
|
removeFileIfExists (specDir `ba` "outputFile")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "copyFile, input file does not exist" $
|
||||||
|
copyFile' (specDir `ba` "noSuchFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "copyFile, no permission to write to output directory" $
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "outputDirNoWrite/outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFile, cannot open output directory" $
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "noPerms/outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFile, cannot open source directory" $
|
||||||
|
copyFile' (specDir `ba` "noPerms/inputFile")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "copyFile, wrong input type (symlink)" $
|
||||||
|
copyFile' (specDir `ba` "inputFileSymL")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "copyFile, wrong input type (directory)" $
|
||||||
|
copyFile' (specDir `ba` "wrongInput")
|
||||||
|
(specDir `ba` "outputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "copyFile, output file already exists" $
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
it "copyFile, output file already exists and is a dir" $
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "copyFile, output and input are same file" $
|
||||||
|
copyFile' (specDir `ba` "inputFile")
|
||||||
|
(specDir `ba` "inputFile")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
54
test/FileSystem/FileOperations/CreateDirSpec.hs
Normal file
54
test/FileSystem/FileOperations/CreateDirSpec.hs
Normal file
@@ -0,0 +1,54 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CreateDirSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/createDirSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.createDir" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "createDir, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "newDir")
|
||||||
|
removeDirIfExists (specDir `ba` "newDir")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "createDir, can't write to output directory" $
|
||||||
|
createDir' (specDir `ba` "noWritePerms/newDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "createDir, can't open output directory" $
|
||||||
|
createDir' (specDir `ba` "noPerms/newDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "createDir, destination directory already exists" $
|
||||||
|
createDir' (specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
54
test/FileSystem/FileOperations/CreateRegularFileSpec.hs
Normal file
54
test/FileSystem/FileOperations/CreateRegularFileSpec.hs
Normal file
@@ -0,0 +1,54 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.CreateRegularFileSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/createRegularFileSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.createRegularFile" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "createRegularFile, all fine" $ do
|
||||||
|
createRegularFile' (specDir `ba` "newDir")
|
||||||
|
removeFileIfExists (specDir `ba` "newDir")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "createRegularFile, can't write to destination directory" $
|
||||||
|
createRegularFile' (specDir `ba` "noWritePerms/newDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "createRegularFile, can't write to destination directory" $
|
||||||
|
createRegularFile' (specDir `ba` "noPerms/newDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "createRegularFile, destination file already exists" $
|
||||||
|
createRegularFile' (specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
97
test/FileSystem/FileOperations/DeleteDirRecursiveSpec.hs
Normal file
97
test/FileSystem/FileOperations/DeleteDirRecursiveSpec.hs
Normal file
@@ -0,0 +1,97 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.DeleteDirRecursiveSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import System.Posix.Files.ByteString
|
||||||
|
(
|
||||||
|
getSymbolicLinkStatus
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/deleteDirRecursiveSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.deleteDirRecursive" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "deleteDirRecursive, empty directory, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "testDir")
|
||||||
|
deleteDirRecursive' (specDir `ba` "testDir")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "testDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "deleteDirRecursive, empty directory with null permissions, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "noPerms/testDir")
|
||||||
|
noPerms (specDir `ba` "noPerms/testDir")
|
||||||
|
deleteDirRecursive' (specDir `ba` "noPerms/testDir")
|
||||||
|
|
||||||
|
it "deleteDirRecursive, non-empty directory, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "nonEmpty")
|
||||||
|
createDir' (specDir `ba` "nonEmpty/dir1")
|
||||||
|
createDir' (specDir `ba` "nonEmpty/dir2")
|
||||||
|
createDir' (specDir `ba` "nonEmpty/dir2/dir3")
|
||||||
|
createRegularFile' (specDir `ba` "nonEmpty/file1")
|
||||||
|
createRegularFile' (specDir `ba` "nonEmpty/dir1/file2")
|
||||||
|
deleteDirRecursive' (specDir `ba` "nonEmpty")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "nonEmpty")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "deleteDirRecursive, can't open parent directory" $ do
|
||||||
|
createDir' (specDir `ba` "noPerms/foo")
|
||||||
|
noPerms (specDir `ba` "noPerms")
|
||||||
|
(deleteDirRecursive' (specDir `ba` "noPerms/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied))
|
||||||
|
>> normalDirPerms (specDir `ba` "noPerms")
|
||||||
|
>> deleteDir' (specDir `ba` "noPerms/foo")
|
||||||
|
|
||||||
|
it "deleteDirRecursive, can't write to parent directory" $ do
|
||||||
|
createDir' (specDir `ba` "noWritable/foo")
|
||||||
|
noWritableDirPerms (specDir `ba` "noWritable")
|
||||||
|
(deleteDirRecursive' (specDir `ba` "noWritable/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied))
|
||||||
|
normalDirPerms (specDir `ba` "noWritable")
|
||||||
|
deleteDir' (specDir `ba` "noWritable/foo")
|
||||||
|
|
||||||
|
it "deleteDirRecursive, wrong file type (symlink to directory)" $
|
||||||
|
deleteDirRecursive' (specDir `ba` "dirSym")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "deleteDirRecursive, wrong file type (regular file)" $
|
||||||
|
deleteDirRecursive' (specDir `ba` "file")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "deleteDirRecursive, directory does not exist" $
|
||||||
|
deleteDirRecursive' (specDir `ba` "doesNotExist")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
|
||||||
94
test/FileSystem/FileOperations/DeleteDirSpec.hs
Normal file
94
test/FileSystem/FileOperations/DeleteDirSpec.hs
Normal file
@@ -0,0 +1,94 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.DeleteDirSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import System.Posix.Files.ByteString
|
||||||
|
(
|
||||||
|
getSymbolicLinkStatus
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/deleteDirSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.deleteDir" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "deleteDir, empty directory, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "testDir")
|
||||||
|
deleteDir' (specDir `ba` "testDir")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "testDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "deleteDir, directory with null permissions, all fine" $ do
|
||||||
|
createDir' (specDir `ba` "noPerms/testDir")
|
||||||
|
noPerms (specDir `ba` "noPerms/testDir")
|
||||||
|
deleteDir' (specDir `ba` "noPerms/testDir")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "testDir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "deleteDir, wrong file type (symlink to directory)" $
|
||||||
|
deleteDir' (specDir `ba` "dirSym")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "deleteDir, wrong file type (regular file)" $
|
||||||
|
deleteDir' (specDir `ba` "file")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "deleteDir, directory does not exist" $
|
||||||
|
deleteDir' (specDir `ba` "doesNotExist")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "deleteDir, directory not empty" $
|
||||||
|
deleteDir' (specDir `ba` "dir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == UnsatisfiedConstraints)
|
||||||
|
|
||||||
|
it "deleteDir, can't open parent directory" $ do
|
||||||
|
createDir' (specDir `ba` "noPerms/foo")
|
||||||
|
noPerms (specDir `ba` "noPerms")
|
||||||
|
(deleteDir' (specDir `ba` "noPerms/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied))
|
||||||
|
>> normalDirPerms (specDir `ba` "noPerms")
|
||||||
|
>> deleteDir' (specDir `ba` "noPerms/foo")
|
||||||
|
|
||||||
|
it "deleteDir, can't write to parent directory, still fine" $ do
|
||||||
|
createDir' (specDir `ba` "noWritable/foo")
|
||||||
|
noWritableDirPerms (specDir `ba` "noWritable")
|
||||||
|
(deleteDir' (specDir `ba` "noWritable/foo")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied))
|
||||||
|
normalDirPerms (specDir `ba` "noWritable")
|
||||||
|
deleteDir' (specDir `ba` "noWritable/foo")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
69
test/FileSystem/FileOperations/DeleteFileSpec.hs
Normal file
69
test/FileSystem/FileOperations/DeleteFileSpec.hs
Normal file
@@ -0,0 +1,69 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.DeleteFileSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import System.Posix.Files.ByteString
|
||||||
|
(
|
||||||
|
getSymbolicLinkStatus
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/deleteFileSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.deleteFile" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "deleteFile, regular file, all fine" $ do
|
||||||
|
createRegularFile' (specDir `ba` "testFile")
|
||||||
|
deleteFile' (specDir `ba` "testFile")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "testFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "deleteFile, symlink, all fine" $ do
|
||||||
|
recreateSymlink' (specDir `ba` "syml")
|
||||||
|
(specDir `ba` "testFile")
|
||||||
|
deleteFile' (specDir `ba` "testFile")
|
||||||
|
getSymbolicLinkStatus (specDir `ba` "testFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "deleteFile, wrong file type (directory)" $
|
||||||
|
deleteFile' (specDir `ba` "dir")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "deleteFile, file does not exist" $
|
||||||
|
deleteFile' (specDir `ba` "doesNotExist")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "deleteFile, can't read directory" $
|
||||||
|
deleteFile' (specDir `ba` "noPerms/blah")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
88
test/FileSystem/FileOperations/GetDirsFilesSpec.hs
Normal file
88
test/FileSystem/FileOperations/GetDirsFilesSpec.hs
Normal file
@@ -0,0 +1,88 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.GetDirsFilesSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Data.List
|
||||||
|
(
|
||||||
|
sort
|
||||||
|
)
|
||||||
|
import Data.Maybe
|
||||||
|
(
|
||||||
|
fromJust
|
||||||
|
)
|
||||||
|
import qualified HPath as P
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import System.Posix.Env.ByteString
|
||||||
|
(
|
||||||
|
getEnv
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/getDirsFilesSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.getDirsFiles" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "getDirsFiles, all fine" $ do
|
||||||
|
pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs
|
||||||
|
expectedFiles <- mapM P.parseRel [(specDir `ba ` ".hidden")
|
||||||
|
,(specDir `ba ` "Lala")
|
||||||
|
,(specDir `ba ` "dir")
|
||||||
|
,(specDir `ba ` "dirsym")
|
||||||
|
,(specDir `ba ` "file")
|
||||||
|
,(specDir `ba ` "noPerms")
|
||||||
|
,(specDir `ba ` "syml")]
|
||||||
|
(fmap sort $ getDirsFiles' specDir)
|
||||||
|
`shouldReturn` fmap (pwd P.</>) expectedFiles
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "getDirsFiles, nonexistent directory" $
|
||||||
|
getDirsFiles' (specDir `ba ` "nothingHere")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "getDirsFiles, wrong file type (file)" $
|
||||||
|
getDirsFiles' (specDir `ba ` "file")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InappropriateType)
|
||||||
|
|
||||||
|
it "getDirsFiles, wrong file type (symlink to file)" $
|
||||||
|
getDirsFiles' (specDir `ba ` "syml")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "getDirsFiles, wrong file type (symlink to dir)" $
|
||||||
|
getDirsFiles' (specDir `ba ` "dirsym")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "getDirsFiles, can't open directory" $
|
||||||
|
getDirsFiles' (specDir `ba ` "noPerms")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
70
test/FileSystem/FileOperations/GetFileTypeSpec.hs
Normal file
70
test/FileSystem/FileOperations/GetFileTypeSpec.hs
Normal file
@@ -0,0 +1,70 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.GetFileTypeSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import HSFM.FileSystem.FileOperations
|
||||||
|
import Test.Hspec
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/getFileTypeSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.getFileType" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "getFileType, regular file" $
|
||||||
|
getFileType' (specDir `ba` "regularfile")
|
||||||
|
`shouldReturn` RegularFile
|
||||||
|
|
||||||
|
it "getFileType, directory" $
|
||||||
|
getFileType' (specDir `ba` "directory")
|
||||||
|
`shouldReturn` Directory
|
||||||
|
|
||||||
|
it "getFileType, directory with null permissions" $
|
||||||
|
getFileType' (specDir `ba` "noPerms")
|
||||||
|
`shouldReturn` Directory
|
||||||
|
|
||||||
|
it "getFileType, symlink to file" $
|
||||||
|
getFileType' (specDir `ba` "symlink")
|
||||||
|
`shouldReturn` SymbolicLink
|
||||||
|
|
||||||
|
it "getFileType, symlink to directory" $
|
||||||
|
getFileType' (specDir `ba` "symlinkD")
|
||||||
|
`shouldReturn` SymbolicLink
|
||||||
|
|
||||||
|
it "getFileType, broken symlink" $
|
||||||
|
getFileType' (specDir `ba` "brokenSymlink")
|
||||||
|
`shouldReturn` SymbolicLink
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "getFileType, file does not exist" $
|
||||||
|
getFileType' (specDir `ba` "nothingHere")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "getFileType, can't open directory" $
|
||||||
|
getFileType' (specDir `ba` "noPerms/forz")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
93
test/FileSystem/FileOperations/MoveFileOverwriteSpec.hs
Normal file
93
test/FileSystem/FileOperations/MoveFileOverwriteSpec.hs
Normal file
@@ -0,0 +1,93 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.MoveFileOverwriteSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/moveFileOverwriteSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.moveFileOverwrite" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "moveFileOverwrite, all fine" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "moveFileOverwrite, all fine" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "dir/movedFile")
|
||||||
|
|
||||||
|
it "moveFileOverwrite, all fine on symlink" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "moveFileOverwrite, all fine on directory" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "dir")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "moveFileOverwrite, destination file already exists" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "moveFileOverwrite, source file does not exist" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "fileDoesNotExist")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "moveFileOverwrite, can't write to destination directory" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noWritePerm/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "moveFileOverwrite, can't open destination directory" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noPerms/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "moveFileOverwrite, can't open source directory" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "noPerms/myFile")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "moveFileOverwrite, move from file to dir" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
isDirDoesExist
|
||||||
|
|
||||||
|
it "moveFileOverwrite, source and dest are same file" $
|
||||||
|
moveFileOverwrite' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "myFile")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
|
|
||||||
95
test/FileSystem/FileOperations/MoveFileSpec.hs
Normal file
95
test/FileSystem/FileOperations/MoveFileSpec.hs
Normal file
@@ -0,0 +1,95 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.MoveFileSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/moveFileSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.moveFile" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "moveFile, all fine" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "moveFile, all fine" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "dir/movedFile")
|
||||||
|
|
||||||
|
it "moveFile, all fine on symlink" $
|
||||||
|
moveFile' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "moveFile, all fine on directory" $
|
||||||
|
moveFile' (specDir `ba` "dir")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "moveFile, source file does not exist" $
|
||||||
|
moveFile' (specDir `ba` "fileDoesNotExist")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "moveFile, can't write to destination directory" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noWritePerm/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "moveFile, can't open destination directory" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noPerms/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "moveFile, can't open source directory" $
|
||||||
|
moveFile' (specDir `ba` "noPerms/myFile")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "moveFile, destination file already exists" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
isFileDoesExist
|
||||||
|
|
||||||
|
it "moveFile, move from file to dir" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
isDirDoesExist
|
||||||
|
|
||||||
|
it "moveFile, source and dest are same file" $
|
||||||
|
moveFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "myFile")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
|
|
||||||
95
test/FileSystem/FileOperations/RecreateSymlinkSpec.hs
Normal file
95
test/FileSystem/FileOperations/RecreateSymlinkSpec.hs
Normal file
@@ -0,0 +1,95 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.RecreateSymlinkSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/recreateSymlinkSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.recreateSymlink" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "recreateSymLink, all fine" $ do
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
removeFileIfExists (specDir `ba` "movedFile")
|
||||||
|
|
||||||
|
it "recreateSymLink, all fine" $ do
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "dir/movedFile")
|
||||||
|
removeFileIfExists (specDir `ba` "dir/movedFile")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "recreateSymLink, wrong input type (file)" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "recreateSymLink, wrong input type (directory)" $
|
||||||
|
recreateSymlink' (specDir `ba` "dir")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == InvalidArgument)
|
||||||
|
|
||||||
|
it "recreateSymLink, can't write to destination directory" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "noWritePerm/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "recreateSymLink, can't open destination directory" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "noPerms/movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "recreateSymLink, can't open source directory" $
|
||||||
|
recreateSymlink' (specDir `ba` "noPerms/myFileL")
|
||||||
|
(specDir `ba` "movedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "recreateSymLink, destination file already exists" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
it "recreateSymLink, destination already exists and is a dir" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == AlreadyExists)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "recreateSymLink, source and destination are the same file" $
|
||||||
|
recreateSymlink' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "myFileL")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
|
|
||||||
95
test/FileSystem/FileOperations/RenameFileSpec.hs
Normal file
95
test/FileSystem/FileOperations/RenameFileSpec.hs
Normal file
@@ -0,0 +1,95 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module FileSystem.FileOperations.RenameFileSpec where
|
||||||
|
|
||||||
|
|
||||||
|
import Test.Hspec
|
||||||
|
import HSFM.FileSystem.Errors
|
||||||
|
import System.IO.Error
|
||||||
|
(
|
||||||
|
ioeGetErrorType
|
||||||
|
)
|
||||||
|
import GHC.IO.Exception
|
||||||
|
(
|
||||||
|
IOErrorType(..)
|
||||||
|
)
|
||||||
|
import Utils
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.UTF8 (toString)
|
||||||
|
|
||||||
|
|
||||||
|
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||||
|
ba = BS.append
|
||||||
|
|
||||||
|
specDir :: BS.ByteString
|
||||||
|
specDir = "test/FileSystem/FileOperations/renameFileSpec/"
|
||||||
|
|
||||||
|
specDir' :: String
|
||||||
|
specDir' = toString specDir
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "HSFM.FileSystem.FileOperations.renameFile" $ do
|
||||||
|
|
||||||
|
-- successes --
|
||||||
|
it "renameFile, all fine" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "renamedFile")
|
||||||
|
|
||||||
|
it "renameFile, all fine" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "dir/renamedFile")
|
||||||
|
|
||||||
|
it "renameFile, all fine on symlink" $
|
||||||
|
renameFile' (specDir `ba` "myFileL")
|
||||||
|
(specDir `ba` "renamedFile")
|
||||||
|
|
||||||
|
it "renameFile, all fine on directory" $
|
||||||
|
renameFile' (specDir `ba` "dir")
|
||||||
|
(specDir `ba` "renamedFile")
|
||||||
|
|
||||||
|
-- posix failures --
|
||||||
|
it "renameFile, source file does not exist" $
|
||||||
|
renameFile' (specDir `ba` "fileDoesNotExist")
|
||||||
|
(specDir `ba` "renamedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == NoSuchThing)
|
||||||
|
|
||||||
|
it "renameFile, can't write to output directory" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noWritePerm/renamedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "renameFile, can't open output directory" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "noPerms/renamedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
it "renameFile, can't open source directory" $
|
||||||
|
renameFile' (specDir `ba` "noPerms/myFile")
|
||||||
|
(specDir `ba` "renamedFile")
|
||||||
|
`shouldThrow`
|
||||||
|
(\e -> ioeGetErrorType e == PermissionDenied)
|
||||||
|
|
||||||
|
-- custom failures --
|
||||||
|
it "renameFile, destination file already exists" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExists")
|
||||||
|
`shouldThrow`
|
||||||
|
isFileDoesExist
|
||||||
|
|
||||||
|
it "renameFile, move from file to dir" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "alreadyExistsD")
|
||||||
|
`shouldThrow`
|
||||||
|
isDirDoesExist
|
||||||
|
|
||||||
|
it "renameFile, source and dest are same file" $
|
||||||
|
renameFile' (specDir `ba` "myFile")
|
||||||
|
(specDir `ba` "myFile")
|
||||||
|
`shouldThrow`
|
||||||
|
isSameFile
|
||||||
|
|
||||||
@@ -0,0 +1,8 @@
|
|||||||
|
dadasasddas
|
||||||
|
sda
|
||||||
|
|
||||||
|
!!1
|
||||||
|
sda
|
||||||
|
|
||||||
|
|
||||||
|
11
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
dadasasddas
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
dadasasddas
|
||||||
|
das
|
||||||
|
sda
|
||||||
|
sda
|
||||||
@@ -0,0 +1,8 @@
|
|||||||
|
dadasasddas
|
||||||
|
sda
|
||||||
|
|
||||||
|
!!1
|
||||||
|
sda
|
||||||
|
|
||||||
|
|
||||||
|
11
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
dadasasddas
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
dadasasddas
|
||||||
|
das
|
||||||
|
sda
|
||||||
|
sda
|
||||||
@@ -0,0 +1,8 @@
|
|||||||
|
dadasasddas
|
||||||
|
sda
|
||||||
|
|
||||||
|
!!1
|
||||||
|
sda
|
||||||
|
|
||||||
|
|
||||||
|
11
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
dadasasddas
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
dadasasddas
|
||||||
|
das
|
||||||
|
sda
|
||||||
|
sda
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
inputDir/
|
||||||
@@ -0,0 +1,8 @@
|
|||||||
|
dadasasddas
|
||||||
|
sda
|
||||||
|
|
||||||
|
!!1
|
||||||
|
sda
|
||||||
|
|
||||||
|
|
||||||
|
11
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
dadasasddas
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
dadasasddas
|
||||||
|
das
|
||||||
|
sda
|
||||||
|
sda
|
||||||
@@ -0,0 +1,8 @@
|
|||||||
|
dadasasddas
|
||||||
|
sda
|
||||||
|
|
||||||
|
!!1
|
||||||
|
sda
|
||||||
|
|
||||||
|
|
||||||
|
11
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
dadasasddas
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
dadasasddas
|
||||||
|
das
|
||||||
|
sda
|
||||||
|
sda
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
inputDir/
|
||||||
@@ -0,0 +1,16 @@
|
|||||||
|
adaöölsdaöl
|
||||||
|
dsalö
|
||||||
|
ölsda
|
||||||
|
ääödsf
|
||||||
|
äsdfä
|
||||||
|
öä453
|
||||||
|
öä
|
||||||
|
435
|
||||||
|
ä45343
|
||||||
|
5
|
||||||
|
453
|
||||||
|
453453453
|
||||||
|
das
|
||||||
|
asd
|
||||||
|
das
|
||||||
|
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
abc
|
||||||
|
def
|
||||||
|
|
||||||
|
dsadasdsa
|
||||||
@@ -0,0 +1 @@
|
|||||||
|
inputFile
|
||||||
2
test/FileSystem/FileOperations/copyFileSpec/inputFile
Normal file
2
test/FileSystem/FileOperations/copyFileSpec/inputFile
Normal file
@@ -0,0 +1,2 @@
|
|||||||
|
abc
|
||||||
|
def
|
||||||
1
test/FileSystem/FileOperations/copyFileSpec/inputFileSymL
Symbolic link
1
test/FileSystem/FileOperations/copyFileSpec/inputFileSymL
Symbolic link
@@ -0,0 +1 @@
|
|||||||
|
inputFile
|
||||||
0
test/FileSystem/FileOperations/createDirSpec/.keep
Normal file
0
test/FileSystem/FileOperations/createDirSpec/.keep
Normal file
1
test/FileSystem/FileOperations/deleteDirRecursiveSpec/dirSym
Symbolic link
1
test/FileSystem/FileOperations/deleteDirRecursiveSpec/dirSym
Symbolic link
@@ -0,0 +1 @@
|
|||||||
|
dir
|
||||||
0
test/FileSystem/FileOperations/deleteDirSpec/.keep
Normal file
0
test/FileSystem/FileOperations/deleteDirSpec/.keep
Normal file
1
test/FileSystem/FileOperations/deleteDirSpec/dirSym
Symbolic link
1
test/FileSystem/FileOperations/deleteDirSpec/dirSym
Symbolic link
@@ -0,0 +1 @@
|
|||||||
|
dir
|
||||||
0
test/FileSystem/FileOperations/deleteDirSpec/file
Normal file
0
test/FileSystem/FileOperations/deleteDirSpec/file
Normal file
0
test/FileSystem/FileOperations/deleteFileSpec/foo
Normal file
0
test/FileSystem/FileOperations/deleteFileSpec/foo
Normal file
1
test/FileSystem/FileOperations/deleteFileSpec/syml
Symbolic link
1
test/FileSystem/FileOperations/deleteFileSpec/syml
Symbolic link
@@ -0,0 +1 @@
|
|||||||
|
foo
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user